/src/clos-class3.lisp

;;;; Common Lisp Object System for CLISP
;;;; Class metaobjects
;;;; Part 3: Class definition and redefinition.
;;;; Bruno Haible 21.8.1993 - 2004
;;;; Sam Steingold 1998 - 2007
;;;; German comments translated into English: Stefan Kain 2002-04-08

(in-package "CLOS")


;; Wipe out all traces of an earlier loaded CLOS.
(eval-when (load eval)
  (do-all-symbols (s) (remprop s 'CLOSCLASS)))

;; CLtL2 28.1.4., ANSI CL 4.3.7. Integrating Types and Classes
(defun subclassp (class1 class2)
  (unless (>= (class-initialized class1) 4) (finalize-inheritance class1))
  (values
    (gethash class2 (class-all-superclasses class1)))) ; T or (default) NIL

;; Continue bootstrapping.
(%defclos
  ;; distinctive marks for CLASS-P
  *<standard-class>-class-version*
  *<structure-class>-class-version*
  *<built-in-class>-class-version*
  'defined-class
  'class
  ;; built-in-classes for CLASS-OF
  (vector 'array 'bit-vector 'character 'complex 'cons 'float 'function
          'hash-table 'integer 'list 'null 'package 'pathname
          #+LOGICAL-PATHNAMES 'logical-pathname
          'random-state 'ratio 'readtable
          'stream 'file-stream 'synonym-stream 'broadcast-stream
          'concatenated-stream 'two-way-stream 'echo-stream 'string-stream
          'string 'symbol 't 'vector))

;; Bootstrapping support.
(defun replace-class-version (class class-version)
  (replace class-version (class-current-version class))
  (setf (class-current-version class) class-version))

;;; -------------------------------- DEFCLASS --------------------------------

(defmacro defclass (&whole whole-form
                    name superclass-specs slot-specs &rest options)
  (unless (symbolp name)
    (error-of-type 'ext:source-program-error
      :form whole-form
      :detail name
      (TEXT "~S: class name ~S should be a symbol")
      'defclass name))
  (let* ((superclass-forms
           (progn
             (unless (listp superclass-specs)
               (error-of-type 'ext:source-program-error
                 :form whole-form
                 :detail superclass-specs
                 (TEXT "~S ~S: expecting list of superclasses instead of ~S")
                 'defclass name superclass-specs))
             (mapcar #'(lambda (superclass)
                         (unless (symbolp superclass)
                           (error-of-type 'ext:source-program-error
                             :form whole-form
                             :detail superclass
                             (TEXT "~S ~S: superclass name ~S should be a symbol")
                             'defclass name superclass))
                         `',superclass)
                       superclass-specs)))
         (accessor-method-decl-forms '())
         (accessor-function-decl-forms '())
         (generic-accessors nil) (generic-accessors-arg 'T)
         (slot-forms
           (let ((slot-names '()))
             (unless (listp slot-specs)
               (error-of-type 'ext:source-program-error
                 :form whole-form
                 :detail slot-specs
                 (TEXT "~S ~S: expecting list of slot specifications instead of ~S")
                 'defclass name slot-specs))
             (when (and (oddp (length slot-specs)) (cdr slot-specs)
                        (do ((l (cdr slot-specs) (cddr l)))
                            ((endp l) t)
                          (unless (keywordp (car l))
                            (return nil))))
               ;; Typical beginner error: Omission of the parentheses around the
               ;; slot-specs. Probably someone who knows DEFSTRUCT and uses
               ;; DEFCLASS for the first time.
               (clos-warning (TEXT "~S ~S: Every second slot name is a keyword, and these slots have no options. If you want to define a slot with options, you need to enclose all slot specifications in parentheses: ~S, not ~S.")
                 'defclass name (list slot-specs) slot-specs))
             (mapcar #'(lambda (slot-spec)
                         (let ((slot-name slot-spec) (slot-options '()))
                           (when (consp slot-spec)
                             (setq slot-name (car slot-spec)
                                   slot-options (cdr slot-spec)))
                           (unless (symbolp slot-name)
                             (error-of-type 'ext:source-program-error
                               :form whole-form
                               :detail slot-name
                               (TEXT "~S ~S: slot name ~S should be a symbol")
                               'defclass name slot-name))
                           (if (memq slot-name slot-names)
                             (error-of-type 'ext:source-program-error
                               :form whole-form
                               :detail slot-names
                               (TEXT "~S ~S: There may be only one direct slot with the name ~S.")
                               'defclass name slot-name)
                             (push slot-name slot-names))
                           (let ((readers '())
                                 (writers '())
                                 (allocations '())
                                 (initargs '())
                                 (initform nil) (initfunction nil)
                                 (types '())
                                 (documentation nil)
                                 (user-defined-args nil))
                             (when (oddp (length slot-options))
                               (error-of-type 'ext:source-program-error
                                 :form whole-form
                                 :detail slot-options
                                 (TEXT "~S ~S: slot options for slot ~S must come in pairs")
                                 'defclass name slot-name))
                             (do ((optionsr slot-options (cddr optionsr)))
                                 ((atom optionsr))
                               (let ((optionkey (first optionsr))
                                     (argument (second optionsr)))
                                 (case optionkey
                                   (:READER
                                    (unless (and (symbolp argument) argument)
                                      (error-of-type 'ext:source-program-error
                                        :form whole-form
                                        :detail argument
                                        (TEXT "~S ~S, slot option for slot ~S: ~S is not a non-NIL symbol")
                                        'defclass name slot-name argument))
                                    (push argument readers))
                                   (:WRITER
                                    (unless (function-name-p argument)
                                      (error-of-type 'ext:source-program-error
                                        :form whole-form
                                        :detail argument
                                        (TEXT "~S ~S, slot option for slot ~S: ~S is not a function name")
                                        'defclass name slot-name argument))
                                    (push argument writers))
                                   (:ACCESSOR
                                    (unless (and (symbolp argument) argument)
                                      (error-of-type 'ext:source-program-error
                                        :form whole-form
                                        :detail argument
                                        (TEXT "~S ~S, slot option for slot ~S: ~S is not a non-NIL symbol")
                                        'defclass name slot-name argument))
                                    (push argument readers)
                                    (push `(SETF ,argument) writers))
                                   (:ALLOCATION
                                    (unless (symbolp argument)
                                      (error-of-type 'ext:source-program-error
                                        :form whole-form
                                        :detail argument
                                        (TEXT "~S ~S, slot option ~S for slot ~S: ~S is not a symbol")
                                        'defclass name ':allocation slot-name argument))
                                    (when allocations
                                      (error-of-type 'ext:source-program-error
                                        :form whole-form
                                        :detail slot-options
                                        (TEXT "~S ~S, slot option ~S for slot ~S may only be given once")
                                        'defclass name ':allocation slot-name))
                                    (setq allocations (list argument)))
                                   (:INITARG
                                    (unless (symbolp argument)
                                      (error-of-type 'ext:source-program-error
                                        :form whole-form
                                        :detail argument
                                        (TEXT "~S ~S, slot option for slot ~S: ~S is not a symbol")
                                        'defclass name slot-name argument))
                                    (push argument initargs))
                                   (:INITFORM
                                    (when initform
                                      (error-of-type 'ext:source-program-error
                                        :form whole-form
                                        :detail slot-options
                                        (TEXT "~S ~S, slot option ~S for slot ~S may only be given once")
                                        'defclass name ':initform slot-name))
                                    (setq initform `(QUOTE ,argument)
                                          initfunction (make-initfunction-form argument slot-name)))
                                   (:TYPE
                                    (when types
                                      (error-of-type 'ext:source-program-error
                                        :form whole-form
                                        :detail slot-options
                                        (TEXT "~S ~S, slot option ~S for slot ~S may only be given once")
                                        'defclass name ':type slot-name))
                                    (setq types (list argument)))
                                   (:DOCUMENTATION
                                    (when documentation
                                      (error-of-type 'ext:source-program-error
                                        :form whole-form
                                        :detail slot-options
                                        (TEXT "~S ~S, slot option ~S for slot ~S may only be given once")
                                        'defclass name ':documentation slot-name))
                                    (unless (stringp argument)
                                      (error-of-type 'ext:source-program-error
                                        :form whole-form
                                        :detail argument
                                        (TEXT "~S ~S, slot option for slot ~S: ~S is not a string")
                                        'defclass name slot-name argument))
                                    (setq documentation argument))
                                   ((:NAME :READERS :WRITERS :INITARGS :INITFUNCTION)
                                    ;; These are valid initialization keywords for
                                    ;; <direct-slot-definition>, but nevertheless
                                    ;; not valid DEFCLASS slot options.
                                    (error-of-type 'ext:source-program-error
                                      :form whole-form
                                      :detail optionkey
                                      (TEXT "~S ~S, slot option for slot ~S: ~S is not a valid slot option")
                                      'defclass name slot-name optionkey))
                                   (t
                                     (if (symbolp optionkey)
                                       (let ((acons (assoc optionkey user-defined-args)))
                                         (if acons
                                           (push argument (cdr acons))
                                           (push (list optionkey argument) user-defined-args)))
                                       (error-of-type 'ext:source-program-error
                                         :form whole-form
                                         :detail optionkey
                                         (TEXT "~S ~S, slot option for slot ~S: ~S is not a valid slot option")
                                         'defclass name slot-name optionkey))))))
                             (setq readers (nreverse readers))
                             (setq writers (nreverse writers))
                             (setq user-defined-args (nreverse user-defined-args))
                             (let ((type (if types (first types) 'T)))
                               (dolist (funname readers)
                                 (push `(DECLAIM-METHOD ,funname ((OBJECT ,name)))
                                       accessor-method-decl-forms)
                                 (push `(PROCLAIM '(FUNCTION ,funname (,name) ,type))
                                       accessor-function-decl-forms)
                                 (push `(SYSTEM::EVAL-WHEN-COMPILE (SYSTEM::C-DEFUN ',funname (SYSTEM::LAMBDA-LIST-TO-SIGNATURE '(OBJECT))))
                                       accessor-function-decl-forms))
                               (dolist (funname writers)
                                 (push `(DECLAIM-METHOD ,funname (NEW-VALUE (OBJECT ,name)))
                                       accessor-method-decl-forms)
                                 (push `(PROCLAIM '(FUNCTION ,funname (,type ,name) ,type))
                                       accessor-function-decl-forms)
                                 (push `(SYSTEM::EVAL-WHEN-COMPILE (SYSTEM::C-DEFUN ',funname (SYSTEM::LAMBDA-LIST-TO-SIGNATURE '(NEW-VALUE OBJECT))))
                                       accessor-function-decl-forms)))
                             `(LIST
                                :NAME ',slot-name
                                ,@(when readers `(:READERS ',readers))
                                ,@(when writers `(:WRITERS ',writers))
                                ,@(when allocations `(:ALLOCATION ',(first allocations)))
                                ,@(when initargs `(:INITARGS ',(nreverse initargs)))
                                ,@(when initform `(:INITFORM ,initform :INITFUNCTION ,initfunction))
                                ,@(when types `(:TYPE ',(first types)))
                                ,@(when documentation `(:DOCUMENTATION ',documentation))
                                ,@(when user-defined-args
                                    ;; For error-checking purposes:
                                    `('DEFCLASS-FORM ',whole-form))
                                ,@(mapcan #'(lambda (option)
                                              (list `',(car option)
                                                    ;; If there are multiple occurrences
                                                    ;; of the same option, the values are
                                                    ;; passed as a list. Otherwise a single
                                                    ;; value is passed (not a 1-element list)!
                                                    `',(if (cddr option)
                                                         (nreverse (cdr option))
                                                         (cadr option))))
                                          user-defined-args)))))
                     slot-specs)))
         (metaclass nil) (metaclass-arg nil)
         (direct-default-initargs nil)
         (documentation nil)
         (user-defined-args nil))
    (dolist (option options)
      (block nil
        (when (listp option)
          (let ((optionkey (first option)))
            (when (case optionkey
                    (:METACLASS metaclass)
                    (:DEFAULT-INITARGS direct-default-initargs)
                    (:DOCUMENTATION documentation))
              (error-of-type 'ext:source-program-error
                :form whole-form
                :detail options
                (TEXT "~S ~S, option ~S may only be given once")
                'defclass name optionkey))
            (case optionkey
              (:METACLASS
               (when (eql (length option) 2)
                 (let ((argument (second option)))
                   (unless (symbolp argument)
                     (error-of-type 'ext:source-program-error
                       :form whole-form
                       :detail argument
                       (TEXT "~S ~S, option ~S: ~S is not a symbol")
                       'defclass name option argument))
                   (setq metaclass-arg argument)
                   (setq metaclass `(FIND-CLASS ',argument)))
                 (return)))
              (:DEFAULT-INITARGS
               (let ((list (rest option)))
                 (when (and (consp list) (null (cdr list)) (listp (car list)))
                   (setq list (car list))
                   (clos-warning (TEXT "~S ~S: option ~S should be written ~S")
                     'defclass name option (cons ':DEFAULT-INITARGS list)))
                 (when (oddp (length list))
                   (error-of-type 'ext:source-program-error
                     :form whole-form
                     :detail list
                     (TEXT "~S ~S, option ~S: arguments must come in pairs")
                     'defclass name option))
                 (setq direct-default-initargs
                       `(:DIRECT-DEFAULT-INITARGS
                         (LIST
                          ,@(let ((arglist nil) (formlist nil))
                              (do ((listr list (cddr listr)))
                                  ((atom listr))
                                (unless (symbolp (first listr))
                                  (error-of-type 'ext:source-program-error
                                    :form whole-form
                                    :detail (first listr)
                                    (TEXT "~S ~S, option ~S: ~S is not a symbol")
                                    'defclass name option (first listr)))
                                (when (member (first listr) arglist)
                                  (error-of-type 'ext:source-program-error
                                    :form whole-form
                                    :detail list
                                    (TEXT "~S ~S, option ~S: ~S may only be given once")
                                    'defclass name option (first listr)))
                                (push (first listr) arglist)
                                (push (second listr) formlist))
                              (mapcan #'(lambda (arg form)
                                          `((LIST ',arg ',form ,(make-initfunction-form form arg))))
                                      (nreverse arglist) (nreverse formlist)))))))
               (return))
              (:DOCUMENTATION
               (when (eql (length option) 2)
                 (let ((argument (second option)))
                   (unless (stringp argument)
                     (error-of-type 'ext:source-program-error
                       :form whole-form
                       :detail argument
                       (TEXT "~S ~S, option ~S: ~S is not a string")
                       'defclass name option argument))
                   (setq documentation
                         `(:DOCUMENTATION ',argument)))
                 (return)))
              ((:NAME :DIRECT-SUPERCLASSES :DIRECT-SLOTS :DIRECT-DEFAULT-INITARGS)
               ;; These are valid initialization keywords for <defined-class>,
               ;; but nevertheless not valid DEFCLASS options.
               (error-of-type 'ext:source-program-error
                 :form whole-form
                 :detail option
                 (TEXT "~S ~S: invalid option ~S")
                 'defclass name option))
              (:GENERIC-ACCESSORS
               (when (eql (length option) 2)
                 (let ((argument (second option)))
                   (setq generic-accessors-arg argument)
                   (setq generic-accessors `(:GENERIC-ACCESSORS ',argument))
                   (return))))
              (T
               (when (symbolp optionkey)
                 (when (assoc optionkey user-defined-args)
                   (error-of-type 'ext:source-program-error
                     :form whole-form
                     :detail options
                     (TEXT "~S ~S, option ~S may only be given once")
                     'defclass name optionkey))
                 (push option user-defined-args)
                 (return))))))
        (error-of-type 'ext:source-program-error
          :form whole-form
          :detail option
          (TEXT "~S ~S: invalid option ~S")
          'defclass name option)))
    (setq user-defined-args (nreverse user-defined-args))
    (let ((metaclass-var (gensym))
          (metaclass-keywords-var (gensym)))
      `(LET ()
         (EVAL-WHEN (COMPILE LOAD EVAL)
           (LET* ((,metaclass-var ,(or metaclass '<STANDARD-CLASS>))
                  ,@(if user-defined-args
                      `((,metaclass-keywords-var
                          ,(cond ((or (null metaclass) (eq metaclass-arg 'STANDARD-CLASS))
                                  '*<STANDARD-CLASS>-VALID-INITIALIZATION-KEYWORDS*)
                                 ((eq metaclass-arg 'FUNCALLABLE-STANDARD-CLASS)
                                  '*<FUNCALLABLE-STANDARD-CLASS>-VALID-INITIALIZATION-KEYWORDS*)
                                 (t `(CLASS-VALID-INITIALIZATION-KEYWORDS ,metaclass-var)))))))
             ;; Provide good error messages. The error message from
             ;; ENSURE-CLASS (actually MAKE-INSTANCE) later is unintelligible.
             ,@(if user-defined-args
                 `((UNLESS (EQ ,metaclass-keywords-var 'T)
                     ,@(mapcar #'(lambda (option)
                                   `(UNLESS (MEMBER ',(first option) ,metaclass-keywords-var)
                                      (ERROR-OF-TYPE 'EXT:SOURCE-PROGRAM-ERROR
                                        :FORM ',whole-form
                                        :DETAIL ',option
                                        (TEXT "~S ~S: invalid option ~S")
                                        'DEFCLASS ',name ',option)))
                               user-defined-args))))
             (APPLY #'ENSURE-CLASS
               ',name
               :DIRECT-SUPERCLASSES (LIST ,@superclass-forms)
               :DIRECT-SLOTS (LIST ,@slot-forms)
               :METACLASS ,metaclass-var
               ,@direct-default-initargs
               ,@documentation
               ,@generic-accessors
               ;; Pass user-defined initargs of the metaclass.
               ,@(mapcan #'(lambda (option)
                             (list `',(first option) `',(rest option)))
                         user-defined-args)
               (APPEND
                 ;; Pass the default initargs of the metaclass, in
                 ;; order to erase leftovers from the previous definition.
                 ,(if metaclass
                    `(MAPCAN #'(LAMBDA (X) (LIST (FIRST X) (FUNCALL (THIRD X))))
                             (CLASS-DEFAULT-INITARGS ,metaclass-var))
                    `',*<standard-class>-default-initargs*)
                 (LIST
                   ;; Here we use (unless ... '(... NIL)) because when a class
                   ;; is being redefined, passing :DOCUMENTATION NIL to
                   ;; ENSURE-CLASS means to erase the documentation string,
                   ;; while nothing means to keep it! See MOP p. 57.
                   ,@(unless direct-default-initargs '(:DIRECT-DEFAULT-INITARGS NIL))
                   ,@(unless documentation '(:DOCUMENTATION NIL))
                   ,@(unless generic-accessors '(:GENERIC-ACCESSORS 'T)))))))
         ,@(if generic-accessors-arg
             (nreverse accessor-method-decl-forms) ; the DECLAIM-METHODs
             (nreverse accessor-function-decl-forms)) ; the C-DEFUNs
         (FIND-CLASS ',name)))))

;; DEFCLASS execution:

;; The function responsible for a MAKE-INSTANCES-OBSOLETE call.
(defvar *make-instances-obsolete-caller* 'make-instances-obsolete)

(defun ensure-class-using-class-<t> (class name &rest all-keys
                                     &key (metaclass <standard-class>)
                                          (direct-superclasses '())
                                          (direct-slots '())
                                          (direct-default-initargs '())
                                          (documentation nil)
                                          (fixed-slot-locations nil)
                                     &allow-other-keys)
  (declare (ignore direct-slots direct-default-initargs documentation
                   fixed-slot-locations))
  ;; Argument checks.
  (unless (symbolp name)
    (error (TEXT "~S: class name ~S should be a symbol")
           'ensure-class-using-class name))
  (unless (defined-class-p metaclass)
    (if (symbolp metaclass)
      (setq metaclass
            (cond ((eq metaclass 'standard-class) <standard-class>) ; for bootstrapping
                  (t (find-class metaclass))))
      (error (TEXT "~S for class ~S: metaclass ~S is neither a class or a symbol")
             'ensure-class-using-class name metaclass)))
  (unless (or (eq metaclass <standard-class>) ; for bootstrapping
              (subclassp metaclass <defined-class>))
    (error (TEXT "~S for class ~S: metaclass ~S is not a subclass of CLASS")
           'ensure-class-using-class name metaclass))
  (unless (proper-list-p direct-superclasses)
    (error (TEXT "~S for class ~S: The ~S argument should be a proper list, not ~S")
           'ensure-class-using-class name ':direct-superclasses direct-superclasses))
  (unless (every #'(lambda (x)
                     (or (defined-class-p x)
                         (forward-reference-to-class-p x)
                         (symbolp x)))
                 direct-superclasses)
    (error (TEXT "~S for class ~S: The direct-superclasses list should consist of classes and symbols, not ~S")
           'ensure-class-using-class name direct-superclasses))
  ;; Ignore the old class if the given name is not its "proper name".
  ;; (This is an ANSI CL requirement; it's not clear whether it belongs
  ;; here or in ENSURE-CLASS.)
  (when (and class (not (eq (class-name class) name)))
    (return-from ensure-class-using-class-<t>
      (apply #'ensure-class-using-class nil name all-keys)))
  ;; Decide whether to modify the given class or ignore it.
  (let ((a-semi-standard-class-p (or (eq metaclass <standard-class>)
                                     (subclassp metaclass <semi-standard-class>))))
    (when class
      (cond ((not (eq metaclass (class-of class)))
             ;; This can occur when mixing DEFSTRUCT and DEFCLASS.
             ;; MOP p. 48 says "If the class of the class argument is not the
             ;; same as the class specified by the :metaclass argument, an
             ;; error is signalled." But we can do better: ignore the old
             ;; class, warn and proceed. The old instances will thus keep
             ;; pointing to the old class.
             (clos-warning (TEXT "Cannot redefine ~S with a different metaclass ~S")
               class metaclass)
             (setq class nil))
            ((not a-semi-standard-class-p)
             ;; This can occur when redefining a class defined through
             ;; (DEFCLASS ... (:METACLASS STRUCTURE-CLASS)), which is
             ;; equivalent to re-executed DEFSTRUCT.
             ;; Only <semi-standard-class> subclasses support making instances
             ;; obsolete. Ignore the old class and proceed. The old instances
             ;; will thus keep pointing to the old class.
             (setq class nil)))
      (unless class
        (return-from ensure-class-using-class-<t>
          (apply #'ensure-class-using-class nil name all-keys))))
    ;; Preparation of class initialization arguments.
    (setq all-keys (copy-list all-keys))
    (remf all-keys ':metaclass)
    ;; See which direct superclasses are already defined.
    (setq direct-superclasses
          (mapcar #'(lambda (c)
                      (if (defined-class-p c)
                        c
                        (let ((cn (if (forward-reference-to-class-p c) (class-name c) c)))
                          (assert (symbolp cn))
                          (if a-semi-standard-class-p
                            ;; Need a class. Allocate a forward-referenced-class
                            ;; if none is yet allocated.
                            (or (get cn 'CLOSCLASS)
                                (setf (get cn 'CLOSCLASS)
                                      (make-instance 'forward-referenced-class
                                        :name cn)))
                            ;; Need a defined-class.
                            (find-class cn)))))
                  direct-superclasses))
    (if class
      ;; Modify the class and return the modified class.
      (apply #'reinitialize-instance ; => #'reinitialize-instance-<defined-class>
             class
             :direct-superclasses direct-superclasses
             all-keys)
      (setf (find-class name)
            (setq class
              (apply (cond ((eq metaclass <standard-class>)
                            #'make-instance-<standard-class>)
                           ((eq metaclass <funcallable-standard-class>)
                            #'make-instance-<funcallable-standard-class>)
                           ((eq metaclass <built-in-class>)
                            #'make-instance-<built-in-class>)
                           ((eq metaclass <structure-class>)
                            #'make-instance-<structure-class>)
                           (t #'make-instance))
                     metaclass
                     :name name
                     :direct-superclasses direct-superclasses
                     all-keys))))
    class))

;; Preliminary.
(predefun ensure-class-using-class (class name &rest args
                                    &key (metaclass <standard-class>)
                                         (direct-superclasses '())
                                         (direct-slots '())
                                         (direct-default-initargs '())
                                         (documentation nil)
                                         (fixed-slot-locations nil)
                                    &allow-other-keys)
  (declare (ignore metaclass direct-superclasses direct-slots
                   direct-default-initargs documentation fixed-slot-locations))
  (apply #'ensure-class-using-class-<t> class name args))

;; MOP p. 46
(defun ensure-class (name &rest args
                     &key (metaclass <standard-class>)
                          (direct-superclasses '())
                          (direct-slots '())
                          (direct-default-initargs '())
                          (documentation nil)
                          (fixed-slot-locations nil)
                     &allow-other-keys)
  (declare (ignore metaclass direct-superclasses direct-slots
                   direct-default-initargs documentation fixed-slot-locations))
  (unless (symbolp name)
    (error (TEXT "~S: class name ~S should be a symbol")
           'ensure-class name))
  (let ((result
          (apply #'ensure-class-using-class (find-class name nil) name args)))
    ; A check, to verify that user-defined methods on ensure-class-using-class
    ; work as they should.
    (unless (defined-class-p result)
      (error (TEXT "Wrong ~S result for ~S: not a class: ~S")
             'ensure-class-using-class name result))
    result))

;; Preliminary.
(predefun reader-method-class (class direct-slot &rest initargs)
  (declare (ignore class direct-slot initargs))
  <standard-reader-method>)
(predefun writer-method-class (class direct-slot &rest initargs)
  (declare (ignore class direct-slot initargs))
  <standard-writer-method>)

;; ---------------------------- Class redefinition ----------------------------

;; When this is true, all safety checks about the metaclasses
;; of superclasses are omitted.
(defparameter *allow-mixing-metaclasses* nil)

(defun reinitialize-instance-<defined-class> (class &rest all-keys
                                              &key (name nil name-p)
                                                   (direct-superclasses '() direct-superclasses-p)
                                                   (direct-slots '() direct-slots-p)
                                                   (direct-default-initargs '() direct-default-initargs-p)
                                                   (documentation nil documentation-p)
                                                   (fixed-slot-locations nil fixed-slot-locations-p)
                                              &allow-other-keys
                                              &aux (metaclass (class-of class)))
  (if (and (>= (class-initialized class) 4) ; already finalized?
           (subclassp class <metaobject>))
    ;; Things would go awry when we try to redefine <class> and similar.
    (clos-warning (TEXT "Redefining metaobject class ~S has no effect.") class)
    (progn
      (when direct-superclasses-p
        ;; Normalize the (class-direct-superclasses class) in the same way as
        ;; the direct-superclasses argument, so that we can compare the two
        ;; lists using EQUAL.
        (when (and (subclassp metaclass <standard-class>)
                   (< (class-initialized class) 3))
          (do ((l (class-direct-superclasses class) (cdr l)))
              ((atom l))
            (let ((c (car l)))
              (unless (defined-class-p c)
                (let ((new-c
                        (let ((cn (if (forward-reference-to-class-p c) (class-name c) c)))
                          (assert (symbolp cn))
                          ;; Need a class. Allocate a forward-referenced-class
                          ;; if none is yet allocated.
                          (or (get cn 'CLOSCLASS)
                              (setf (get cn 'CLOSCLASS)
                                    (make-instance 'forward-referenced-class
                                      :name cn))))))
                  (unless (eq new-c c)
                    (when (defined-class-p new-c)
                      ; changed from forward-referenced-class to defined-class
                      (check-allowed-superclass class new-c))
                    (setf (car l) new-c)
                    (when (or (defined-class-p c) (forward-reference-to-class-p c))
                      (remove-direct-subclass c class))
                    (add-direct-subclass new-c class))))))))
      (when direct-slots-p
        ;; Convert the direct-slots to <direct-slot-definition> instances.
        (setq direct-slots (convert-direct-slots class direct-slots)))
      (when fixed-slot-locations-p
        ;; Convert from list to boolean.
        (when (consp fixed-slot-locations)
          (setq fixed-slot-locations (car fixed-slot-locations))))
      ;; Trivial changes (that can occur when loading the same code twice)
      ;; do not require updating the instances:
      ;; changed slot-options :initform, :documentation,
      ;; changed class-options :name, :default-initargs, :documentation.
      (if (or (and direct-superclasses-p
                   (not (equal (or direct-superclasses (default-direct-superclasses class))
                               (class-direct-superclasses class))))
              (and direct-slots-p
                   (not (equal-direct-slots direct-slots (class-direct-slots class))))
              (and direct-default-initargs-p
                   (not (equal-default-initargs direct-default-initargs
                                                (class-direct-default-initargs class))))
              (and fixed-slot-locations-p
                   (not (eq fixed-slot-locations (class-fixed-slot-locations class)))))
        ;; Instances have to be updated:
        (let* ((was-finalized (>= (class-initialized class) 6))
               (must-be-finalized
                 (and was-finalized
                      (some #'class-instantiated (list-all-finalized-subclasses class))))
               (old-direct-superclasses (class-direct-superclasses class))
               (old-direct-accessors (class-direct-accessors class))
               (old-class-precedence-list (and was-finalized (class-precedence-list class)))
               old-class)
          ;; ANSI CL 4.3.6. Remove accessor methods created by old DEFCLASS.
          (remove-accessor-methods old-direct-accessors)
          (setf (class-direct-accessors class) '())
          ;; Clear the cached prototype.
          (setf (class-prototype class) nil)
          ;; Declare all instances as obsolete, and backup the class object.
          (let ((old-version (class-current-version class))
                (*make-instances-obsolete-caller* 'defclass))
            (make-instances-obsolete class)
            (setq old-class (cv-class old-version)))
          (locally (declare (compile))
            (sys::%handler-bind
             #'(lambda ()
                 (apply #'shared-initialize
                                ; => #'shared-initialize-<built-in-class>
                                ;    #'shared-initialize-<standard-class>
                                ;    #'shared-initialize-<structure-class>
                        class nil
                        `(,@(if direct-slots-p
                                (list 'direct-slots direct-slots) '())
                          ,@all-keys))
                 ;; If the class could be finalized (although not a "must"),
                 ;; keep it finalized and don't unfinalize it.
                 (when (>= (class-initialized class) 6)
                   (setq must-be-finalized t))
                 (update-subclasses-for-redefined-class
                  class was-finalized must-be-finalized
                  old-direct-superclasses))
             ;; If an error occurs during the class redefinition,
             ;; switch back to the old definition, so that existing
             ;; instances can continue to be used.
             'ERROR #'(lambda (condition)
                        (declare (ignore condition))
                        (let ((tmp-direct-superclasses (class-direct-superclasses class)))
                          ;; Restore the class using the backup copy.
                          (let ((new-version (class-current-version class)))
                            (dotimes (i (sys::%record-length class))
                              (setf (sys::%record-ref class i) (sys::%record-ref old-class i)))
                            (setf (class-current-version class) new-version))
                          ;; Restore the direct-subclasses pointers.
                          (dolist (super tmp-direct-superclasses)
                            (remove-direct-subclass-internal super class))
                          (dolist (super old-direct-superclasses)
                            (add-direct-subclass-internal super class))
                          ;; Restore the finalized-direct-subclasses pointers.
                          (dolist (super tmp-direct-superclasses)
                            (when (semi-standard-class-p super)
                              (remove-finalized-direct-subclass super class)))
                          (when (>= (class-initialized class) 6)
                            (dolist (super old-direct-superclasses)
                              (when (semi-standard-class-p super)
                                (add-finalized-direct-subclass super class))))
                          ;; Restore the accessor methods.
                          (add-accessor-methods old-direct-accessors)
                          (setf (class-direct-accessors class) old-direct-accessors)))))
          (let ((new-class-precedence-list
                  (and (>= (class-initialized class) 6) (class-precedence-list class))))
            (unless (equal old-class-precedence-list new-class-precedence-list)
              (update-subclass-instance-specializer-generic-functions class)
              (update-subclass-cpl-specializer-generic-functions class
                old-class-precedence-list new-class-precedence-list)))
          (install-class-direct-accessors class))
        ;; Instances don't need to be updated:
        (progn
          (when name-p
            ;; Store new name:
            (setf (class-classname class) name))
          (when direct-slots-p
            ;; Store new slot-inits:
            (do ((l-old (class-direct-slots class) (cdr l-old))
                 (l-new direct-slots (cdr l-new)))
                ((null l-new))
              (let ((old (car l-old))
                    (new (car l-new)))
                (setf (slot-definition-initform old) (slot-definition-initform new))
                (setf (slot-definition-initfunction old) (slot-definition-initfunction new))
                (setf (slot-definition-documentation old) (slot-definition-documentation new)))))
          (when direct-default-initargs-p
            ;; Store new default-initargs:
            (do ((l-old (class-direct-default-initargs class) (cdr l-old))
                 (l-new direct-default-initargs (cdr l-new)))
                ((null l-new))
              (let ((old (cdar l-old))
                    (new (cdar l-new)))
                ;; Move initform and initfunction from new destructively into
                ;; the old one:
                (setf (car old) (car new))
                (setf (cadr old) (cadr new)))))
          (when documentation-p
            ;; Store new documentation:
            (setf (class-documentation class) documentation))
          ;; NB: These modifications are automatically inherited by the
          ;; subclasses of class! Due to <inheritable-slot-definition-initer>
          ;; and <inheritable-slot-definition-doc>.
          ;; No need to call (install-class-direct-accessors class) here.
      ) )
      ;; Try to finalize it (mop-cl-reinit-mo, bug [ 1526448 ])
      (unless *allow-mixing-metaclasses* ; for gray.lisp
        (when (finalizable-p class)
          (finalize-inheritance class)))
      ;; Notification of listeners:
      (map-dependents class
        #'(lambda (dependent)
            (apply #'update-dependent class dependent all-keys)))
  ) )
  class)

(defun equal-direct-slots (slots1 slots2)
  (or (and (null slots1) (null slots2))
      (and (consp slots1) (consp slots2)
           (equal-direct-slot (first slots1) (first slots2))
           (equal-direct-slots (rest slots1) (rest slots2)))))
(defun equal-default-initargs (initargs1 initargs2)
  (or (and (null initargs1) (null initargs2))
      (and (consp initargs1) (consp initargs2)
           (eq (car (first initargs1)) (car (first initargs2)))
           (equal-default-initargs (cdr initargs1) (cdr initargs2)))))

(defun map-dependents-<defined-class> (class function)
  (dolist (dependent (class-listeners class))
    (funcall function dependent)))

;; ------------------- General routines for <defined-class> -------------------

;; Preliminary.
(predefun class-name (class)
  (class-classname class))

;; Returns the list of implicit direct superclasses when none was specified.
(defun default-direct-superclasses (class)
  (cond ((typep class <standard-class>) (list <standard-object>))
        ((typep class <funcallable-standard-class>) (list <funcallable-standard-object>))
        ((typep class <structure-class>) (list <structure-object>))
        (t '())))

(defun check-metaclass-mix (name direct-superclasses metaclass-test metaclass)
  (unless *allow-mixing-metaclasses*
    (unless (every metaclass-test direct-superclasses)
      (error-of-type 'error
        (TEXT "(~S ~S): superclass ~S should be of class ~S")
        'DEFCLASS name (find-if-not metaclass-test direct-superclasses)
        metaclass))))

;; Preliminary.
(predefun validate-superclass (class superclass)
  (or ;; Green light if class and superclass belong to the same metaclass.
      (eq (sys::%record-ref class 0) (sys::%record-ref superclass 0))
      ;; Green light also if class is a funcallable-standard-class and
      ;; superclass is a standard-class.
      (and (eq (sys::%record-ref class 0) *<funcallable-standard-class>-class-version*)
           (eq (sys::%record-ref superclass 0) *<standard-class>-class-version*))
      ;; Other than that, only <standard-object> and <structure-object> can
      ;; inherit from <t> without belonging to the same metaclass.
      (and (eq superclass <t>)
           (memq (class-classname class) '(standard-object structure-object)))
      ;; And only <funcallable-standard-object> can inherit from <function>
      ;; without belonging to the same metaclass.
      (and (eq superclass <function>)
           (eq (class-classname class) 'funcallable-standard-object))))

(defun check-allowed-superclass (class superclass)
  (unless (validate-superclass class superclass)
    (error (TEXT "(~S ~S) for class ~S: ~S does not allow ~S to become a subclass of ~S. You may define a method on ~S to allow this.")
           'initialize-instance 'class (class-classname class) 'validate-superclass class superclass
           'validate-superclass)))

;;; The direct-subclasses slot can be either
;;; - NIL or a weak-list (for saving memory when there are few subclasses), or
;;; - a weak-hash-table (for speed when there are many subclasses).
#|
;; Adds a class to the list of direct subclasses.
(defun add-direct-subclass (class subclass) ...)
;; Removes a class from the list of direct subclasses.
(defun remove-direct-subclass (class subclass) ...)
;; Returns the currently existing direct subclasses, as a freshly consed list.
(defun list-direct-subclasses (class) ...)
|#
(def-weak-set-accessors class-direct-subclasses-table defined-class
  add-direct-subclass-internal
  remove-direct-subclass-internal
  list-direct-subclasses)

;; Preliminary.
(predefun add-direct-subclass (class subclass)
  (add-direct-subclass-internal class subclass))
(predefun remove-direct-subclass (class subclass)
  (remove-direct-subclass-internal class subclass))
(predefun class-direct-subclasses (class)
  (list-direct-subclasses class))

(defun checked-class-direct-subclasses (class)
  (let ((result (class-direct-subclasses class)))
    ; Some checks, to guarantee that user-defined methods on
    ; class-direct-subclasses don't break our CLOS.
    (unless (proper-list-p result)
      (error (TEXT "Wrong ~S result for class ~S: not a proper list: ~S")
             'class-direct-subclasses (class-name class) result))
    (dolist (c result)
      (unless (defined-class-p c)
        (error (TEXT "Wrong ~S result for class ~S: list element is not a class: ~S")
               'class-direct-subclasses (class-name class) c))
      (unless (memq class (class-direct-superclasses c))
        (error (TEXT "Wrong ~S result for class ~S: ~S is not a direct superclass of ~S")
               'class-direct-subclasses (class-name class) class c)))
    result))

(defun update-subclasses-sets (class old-direct-superclasses new-direct-superclasses)
  (unless (equal old-direct-superclasses new-direct-superclasses)
    (let ((removed-direct-superclasses
            (set-difference old-direct-superclasses new-direct-superclasses))
          (added-direct-superclasses
            (set-difference new-direct-superclasses old-direct-superclasses)))
      (dolist (super removed-direct-superclasses)
        (remove-direct-subclass super class))
      (dolist (super added-direct-superclasses)
        (add-direct-subclass super class)))))

;; ----------------------------------------------------------------------------
;; CLtL2 28.1.5., ANSI CL 4.3.5. Determining the Class Precedence List

;; The set of all classes forms a directed graph: Class C is located
;; below the direct superclasses of C. This graph is acyclic, because
;; at the moment of definition of the class C all direct superclasses must
;; already be present.

;; Hence, one can use Noether Induction (Induction from above to below in
;; the class graph) .

;; For a class C let DS(n) be the list of all direct superclasses of C.
;; The set of all superclasses (incl. C itself) is inductively defined as
;; S(C) := {C} union union_{D in DS(C)} S(D).

;; In other words:
;; S(C) = { C_n : C_n in DS(C_{n-1}), ..., C_1 in DS(C_0), C_0 = C }

;; Lemma 1: (a) C in S(C).
;;          (b) DS(C) subset S(C).
;;          (c) D in DS(C) ==> S(D) subset S(C).
;;          (d) D in S(C) ==> S(D) subset S(C).
;; proof:  (a) follows from the definition.
;;         (b) from (a) and from the definition.
;;         (c) from the definition.
;;         (d) from (c) with fixed D via induction over C.

;; The CPL of a class C is one order of set S(C).
;; If CPL(C) = (... D1 ... D2 ...), one writes D1 < D2.
;; The relation introduced by this is a total order upon S(C).
;; The following set of restrictions has to be taken into account:
;; R(C) := union_{D in S(C)} DR(D)  with
;; DR(C) := { C < C1, C1 < C2, ..., C{n-1} < C_n } if DS(C) = (C1, ..., Cn).
;; If R(C) contains a cycle, R(C) cannot be completed into a total order,
;; of course. Then, R(C) is called inconsistent.
;; CPL(C) is constructed as follows:
;;   L := (), R := R(C).
;;   L := (L | C), remove all (C < ..) from R.
;;   while R /= {}, deal with the set M of all minimal elements of R
;;     (those classes, that can be added to L without violating R(C) ).
;;     If M is empty, then there is a cycle in R(C) and
;;     the algorithm is finished. Else, choose that element among the
;;     elements E of M, which has a D being rightmost in L with
;;     E in DS(D) .
;;     L := (L | E), remove all (E < ..) from R.
;;   CPL(C) := L.
;; L is lengthened stepwise by one element, R is shortened stepwise,
;; and R always consists solely of relations between elements
;; of S(C)\L.

;; Lemma 2: (a) CPL(C) = (C ...).
;;          (b) If DS(C) = (C1, ..., Cn), then
;;              CPL(C) = (C ... C1 ... C2 ... ... Cn ...).
;; proof:  (a) obvious by construction.
;;         (b) If Ci is added to the CPL, then the restriction
;;             C{i-1} < Ci can no longer be in R, so C{i-1} must already be
;;             in the CPL.

;; The following statement is wrong:
;; (*) If D is in DS(C) and CPL(D) = (D1, ..., Dn), then
;;     CPL(C) = (C ... D1 ... D2 ... ... Dn ...).
;; Example:
;;     z
;;    /|\             CPL(z) = (z)
;;   / | \            CPL(x) = (x z)
;;  x  |  x           CPL(y) = (y z)
;;  |  |  |           CPL(d) = (d x z)
;;  d  y  e           CPL(e) = (e x z)
;;   \/ \/            CPL(b) = (b d x y z)
;;   b   c            CPL(c) = (c y e x z)
;;    \ /             CPL(a) = (a b d c y e x z)
;;     a
;;                    CPL(a) does not contain CPL(b) !

#||
 (defclass z () ())
 (defclass x (z) ())
 (defclass y (z) ())
 (defclass d (x z) ())
 (defclass e (x z) ())
 (defclass b (d y) ())
 (defclass c (y e) ())
 (defclass a (b c) ())
 (mapcar #'find-class '(z x y d e b c a))
||#

(defun std-compute-cpl (class direct-superclasses)
  (let* ((superclasses ; list of all superclasses in any order
          (remove-duplicates
           (mapcap #'class-precedence-list direct-superclasses)))
         (L '())
         (R1 (list (cons class direct-superclasses)))
         (R2 (mapcar #'(lambda (D) (cons D (class-direct-superclasses D)))
                     superclasses)))
    (loop
      ;; L is the reversed, so far constructed CPL.
      ;; R1 is the list of the so far relevant restrictions, in the form
      ;; R1 = (... (Dj ... Dn) ...) if from DR(D) = (D1 ... Dn) only
      ;; Dj,...,Dn is left over. The order in R1 corresponds to that in L.
      ;; R2 is the list of all so far irrelevant restrictions.
      (when (null R1)
        (return)) ; R1 = R2 = () -> finished
      (let ((M (remove-duplicates (mapcar #'first R1) :from-end t)))
        (setq M (remove-if #'(lambda (E)
                               (or (dolist (r R1 nil)
                                     (when (member E (cdr r)) (return t)))
                                   (dolist (r R2 nil)
                                     (when (member E (cdr r)) (return t)))))
                           (the list M)))
        (when (null M)
          (error-of-type 'error
            (TEXT "~S ~S: inconsistent precedence graph, cycle ~S")
            'defclass (class-classname class)
            ;; find cycle: advance to ever smaller elements
            ;; with aid of the restrictions.
            (let* ((R0 (append R1 R2))
                   (cycle (list (car (first R0)))))
              (loop
                (let* ((last (car cycle))
                       (next (dolist (r R0 nil)
                               (when (member last (cdr r))
                                 (return (nth (position last (cdr r)) r))))))
                  (when (null next)
                    ;; last is now apparently a minimal element, after all!
                    (return '??))
                  (when (member next cycle)
                    (setf (cdr (member next cycle)) nil)
                    (return cycle))
                  (push next cycle))))))
        (let ((E (first M)))
          (push E L)
          (push (assoc E R2) R1)
          (setq R2 (delete E R2 :key #'first))
          (mapl #'(lambda (r) (when (eq (first (car r)) E) (pop (car r)))) R1)
          (setq R1 (delete-if #'null R1)))))
    (setq L (nreverse L))
    ;; Test, if L is compatible with the CPL(D), D in direct-superclasses:
    (mapc #'(lambda (D)
              (unless ; Is (class-precedence-list D) sublist of L ?
                  (do ((CL L)
                       (DL (class-precedence-list D) (cdr DL)))
                      ((null DL) t)
                    (when (null (setq CL (member (car DL) CL))) (return nil)))
                (clos-warning (TEXT "(class-precedence-list ~S) and (class-precedence-list ~S) are inconsistent")
                  class D)))
          direct-superclasses)
    L))

(defun compute-class-precedence-list-<defined-class> (class)
  (std-compute-cpl class (class-direct-superclasses class)))

;; Preliminary.
(predefun compute-class-precedence-list (class)
  (compute-class-precedence-list-<defined-class> class))

(defun checked-compute-class-precedence-list (class)
  (let ((cpl (compute-class-precedence-list class))
        (name (class-name class)))
    ; Some checks, to guarantee that user-defined methods on
    ; compute-class-precedence-list don't break our CLOS.
    (unless (proper-list-p cpl)
      (error (TEXT "Wrong ~S result for class ~S: not a proper list: ~S")
             'compute-class-precedence-list name cpl))
    (dolist (c cpl)
      (unless (defined-class-p c)
        (error (TEXT "Wrong ~S result for class ~S: list element is not a class: ~S")
               'compute-class-precedence-list name c)))
    (unless (eq (first cpl) class)
      (error (TEXT "Wrong ~S result for class ~S: list doesn't start with the class itself: ~S")
             'compute-class-precedence-list name cpl))
    (unless (or (eq name 't) ; for bootstrapping
                (eq (car (last cpl)) <t>))
      (error (TEXT "Wrong ~S result for class ~S: list doesn't end with ~S: ~S")
             'compute-class-precedence-list name <t> cpl))
    (unless (= (length cpl) (length (remove-duplicates cpl :test #'eq)))
      (error (TEXT "Wrong ~S result for class ~S: list contains duplicates: ~S")
             'compute-class-precedence-list name cpl))
    (let ((superclasses (reduce #'union
                                (mapcar #'class-precedence-list
                                        (class-direct-superclasses class))
                                :initial-value '())))
      (let ((forgotten (set-difference superclasses cpl)))
        (when forgotten
          (error (TEXT "Wrong ~S result for class ~S: list doesn't contain the superclass~[~;~:;es~] ~{~S~^, ~}.")
                 'compute-class-precedence-list name (length forgotten) forgotten)))
      (let ((extraneous (set-difference (rest cpl) superclasses)))
        (when extraneous
          (error (TEXT "Wrong ~S result for class ~S: list contains elements that are not superclasses: ~{~S~^, ~}")
                 'compute-class-precedence-list name extraneous))))
    ; Now we've checked the CPL is OK.
    cpl))

;; Stuff all superclasses (from the precedence-list) into a hash-table.
(defun std-compute-superclasses (precedence-list)
  (let ((ht (make-hash-table :key-type 'defined-class :value-type '(eql t)
                             :test 'ext:stablehash-eq :warn-if-needs-rehash-after-gc t)))
    (mapc #'(lambda (superclass) (setf (gethash superclass ht) t))
          precedence-list)
    ht))

;; Determine whether a class inherits from <standard-stablehash> or
;; <structure-stablehash>.
(defun std-compute-subclass-of-stablehash-p (class)
  (dolist (superclass (class-precedence-list class) nil)
    (let ((superclassname (class-classname superclass)))
      (when (or (eq superclassname 'standard-stablehash)
                (eq superclassname 'structure-stablehash))
        (return t)))))

;; ----------------------------------------------------------------------------
;; CLtL2 28.1.3.2., ANSI CL 7.5.3. Inheritance of Slots and Slot Options

(defun compute-effective-slot-definition-initargs-<defined-class> (class directslotdefs)
  (declare (ignore class))
  (unless (and (proper-list-p directslotdefs) (consp directslotdefs))
    (error (TEXT "~S: argument should be a non-empty proper list, not ~S")
           'compute-effective-slot-definition-initargs directslotdefs))
  (dolist (slot directslotdefs)
    (unless (direct-slot-definition-p slot)
      (error (TEXT "~S: argument list element is not a ~S: ~S")
             'compute-effective-slot-definition-initargs 'direct-slot-definition
             slot)))
  (let ((name (slot-definition-name (first directslotdefs))))
    (dolist (slot (rest directslotdefs))
      (unless (eql name (slot-definition-name slot))
        (error (TEXT "~S: argument list elements should all have the same name, not ~S and ~S")
               'compute-effective-slot-definition-initargs name (slot-definition-name slot))))
    `(:name ,name
      ; "The allocation of a slot is controlled by the most
      ;  specific slot specifier."
      :allocation ,(slot-definition-allocation (first directslotdefs))
      ; "The set of initialization arguments that initialize a
      ;  given slot is the union of the initialization arguments
      ;  declared in the :initarg slot options in all the slot
      ;  specifiers.
      ,@(let ((initargs
                (remove-duplicates
                  (mapcap #'slot-definition-initargs directslotdefs)
                  :from-end t)))
          (if initargs `(:initargs ,initargs)))
      ; "The default initial value form for a slot is the value
      ;  of the :initform slot option in the most specific slot
      ;  specifier that contains one."
      ,@(dolist (slot directslotdefs '())
          (when (slot-definition-initfunction slot)
            (return `(:initform ,(slot-definition-initform slot)
                      :initfunction ,(slot-definition-initfunction slot)
                      inheritable-initer ,(slot-definition-inheritable-initer slot)))))
      ; "The contents of a slot will always be of type
      ;  (and T1 ... Tn) where T1 ...Tn are the values of the
      ;  :type slot options contained in all of the slot specifiers."
      ,@(let ((types '()))
          (dolist (slot directslotdefs)
            (push (slot-definition-type slot) types))
          `(:type ,(if types `(AND ,@(nreverse types)) 'T)))
      ; "The documentation string for a slot is the value of the
      ;  :documentation slot option in the most specific slot
      ;  specifier that contains one."
      ,@(dolist (slot directslotdefs '())
          (when (slot-definition-documentation slot)
            (return `(:documentation ,(slot-definition-documentation slot)
                      inheritable-doc ,(slot-definition-inheritable-doc slot)))))
      #|| ; Commented out because <effective-slot-definition>
          ; doesn't have readers and writers.
      ,@(let ((readers (mapcap #'slot-definition-readers directslotdefs)))
          (if readers `(:readers ,readers)))
      ,@(let ((writers (mapcap #'slot-definition-writers directslotdefs)))
          (if writers `(:writers ,writers)))
      ||#
     )))

;; Preliminary.
(predefun compute-effective-slot-definition-initargs (class direct-slot-definitions)
  (compute-effective-slot-definition-initargs-<defined-class> class direct-slot-definitions))

(defun compute-effective-slot-definition-<defined-class> (class name directslotdefs)
  (let ((args (compute-effective-slot-definition-initargs class directslotdefs)))
    ; Some checks, to guarantee that user-defined primary methods on
    ; compute-effective-slot-definition-initargs don't break our CLOS.
    (unless (and (proper-list-p args) (evenp (length args)))
      (error (TEXT "Wrong ~S result for ~S: not a list of keyword/value pairs: ~S")
             'compute-effective-slot-definition-initargs class args))
    (let* ((default '#:default)
           (returned-name (getf args ':name '#:default)))
      (unless (eql returned-name name)
        (if (eq returned-name default)
          (error (TEXT "Wrong ~S result for ~S: missing ~S")
                 'compute-effective-slot-definition-initargs class ':name)
          (error (TEXT "Wrong ~S result for ~S: invalid ~S value")
                 'compute-effective-slot-definition-initargs class ':name))))
    (let ((slot-definition-class
            (apply #'effective-slot-definition-class class args)))
      (cond ((semi-standard-class-p class)
             (unless (or ; for bootstrapping
                         (eq slot-definition-class 'standard-effective-slot-definition)
                         (and (defined-class-p slot-definition-class)
                              (subclassp slot-definition-class <standard-effective-slot-definition>)))
               (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S")
                      'effective-slot-definition-class (class-name class)
                      'standard-effective-slot-definition slot-definition-class)))
            ((structure-class-p class)
             (unless (and (defined-class-p slot-definition-class)
                          (subclassp slot-definition-class <structure-effective-slot-definition>))
               (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S")
                      'effective-slot-definition-class (class-name class)
                      'structure-effective-slot-definition slot-definition-class))))
      (apply (cond ((eq slot-definition-class 'standard-effective-slot-definition)
                    #'make-instance-<standard-effective-slot-definition>)
                   (t #'make-instance))
             slot-definition-class args))))

;; Preliminary.
(predefun compute-effective-slot-definition (class slotname direct-slot-definitions)
  (compute-effective-slot-definition-<defined-class> class slotname direct-slot-definitions))

(defun compute-slots-<defined-class>-primary (class)
  ;; Gather all slot-specifiers, ordered by precedence:
  (let ((all-slots
          (mapcan #'(lambda (c) (nreverse (copy-list (class-direct-slots c))))
                  (class-precedence-list class))))
    ;; Partition by slot-names:
    (setq all-slots
          (let ((ht (make-hash-table :key-type 'symbol :value-type 't
                                     :test 'ext:stablehash-eql :warn-if-needs-rehash-after-gc t)))
            (dolist (slot all-slots)
              (let ((slot-name (slot-definition-name slot)))
                (push slot (gethash slot-name ht nil))))
            (let ((L nil))
              (maphash #'(lambda (name slot-list)
                           (push (cons name (nreverse slot-list)) L))
                       ht)
              L))) ; not (nreverse L), because maphash reverses the order
    ;; Bring the slots into final order: Superclass before subclass, and
    ;; inside each class, keeping the same order as in the direct-slots.
    (setq all-slots (nreverse all-slots))
    ;; all-slots is now a list of lists of the form
    ;; (name most-specific-slot ... least-specific-slot).
    (mapcar
      #'(lambda (slotbag)
          (let ((name (car slotbag))
                (directslotdefs (cdr slotbag)))
            ;; Create the effective slot definition in a way that depends
            ;; only on the class, name, and direct-slot-definitions.
            (let ((eff-slot
                    (compute-effective-slot-definition class name directslotdefs)))
              ; Some checks, to guarantee that user-defined methods on
              ; compute-effective-slot-definition don't break our CLOS.
              (unless (effective-slot-definition-p eff-slot)
                (error (TEXT "Wrong ~S result for class ~S, slot ~S: not an ~S instance: ~S")
                       'compute-effective-slot-definition class name 'effective-slot-definition eff-slot))
              eff-slot)))
      all-slots)))

;; Allocation of local and shared slots.
;; Side effects done by this function: The slot-definition-location of the
;; slots is determined.
(defun compute-slots-<slotted-class>-around (class next-method)
  (let ((cpl (class-precedence-list class))
        (slots (funcall next-method class)))
    ; Some checks, to guarantee that user-defined primary methods on
    ; compute-slots don't break our CLOS.
    (unless (proper-list-p slots)
      (error (TEXT "Wrong ~S result for class ~S: not a proper list: ~S")
             'compute-slots (class-name class) slots))
    (cond ((semi-standard-class-p class)
           (dolist (slot slots)
             (unless (standard-effective-slot-definition-p slot)
               (error (TEXT "Wrong ~S result for class ~S: list element is not a ~S: ~S")
                      'compute-slots (class-name class)
                      'standard-effective-slot-definition slot))))
          ((structure-class-p class)
           (dolist (slot slots)
             (unless (typep-class slot <structure-effective-slot-definition>)
               (error (TEXT "Wrong ~S result for class ~S: list element is not a ~S: ~S")
                      'compute-slots (class-name class)
                      'structure-effective-slot-definition slot)))))
    (unless (= (length slots)
               (length (delete-duplicates (mapcar #'slot-definition-name slots))))
      (error (TEXT "Wrong ~S result for class ~S: list contains duplicate slot names: ~S")
             'compute-slots (class-name class) slots))
    ;; Implementation of fixed-slot-locations policy.
    (let ((superclasses-with-fixed-slot-locations
            (remove-if-not #'(lambda (c)
                               (and (semi-standard-class-p c)
                                    (class-fixed-slot-locations c)))
                           (cdr (class-precedence-list class)))))
      (when superclasses-with-fixed-slot-locations
        (dolist (slot slots)
          (let ((name (slot-definition-name slot))
                (location nil))
            (dolist (superclass superclasses-with-fixed-slot-locations)
              (let ((slot-in-superclass (find name (class-slots superclass)
                                              :key #'slot-definition-name)))
                (when slot-in-superclass
                  (when (eq (slot-definition-allocation slot-in-superclass) ':instance)
                    (let ((guaranteed-location
                            (slot-definition-location slot-in-superclass)))
                      (assert (integerp guaranteed-location))
                      (if location
                        (unless (equal location guaranteed-location)
                          (error (TEXT "In class ~S, the slot ~S is constrained by incompatible constraints inherited from the superclasses.")
                                 (class-name class) name))
                        (setq location guaranteed-location)))))))
            (when location
              (unless (eq (slot-definition-allocation slot) ':instance)
                (error (TEXT "In class ~S, non-local slot ~S is constrained to be a local slot at offset ~S.")
                       (class-name class) name location))
              (setf (slot-definition-location slot) location))))))
    (let ((constrained-indices
            (let ((constrained-slots (remove-if-not #'slot-definition-location slots)))
              (setq constrained-slots (copy-list constrained-slots))
              (setq constrained-slots (sort constrained-slots #'< :key #'slot-definition-location))
              (do ((l constrained-slots (cdr l)))
                  ((null (cdr l)))
                (when (= (slot-definition-location (car l)) (slot-definition-location (cadr l)))
                  (error (TEXT "In class ~S, the slots ~S and ~S are constrained from the superclasses to both be located at offset ~S.")
                         (class-name class)
                         (slot-definition-name (car l)) (slot-definition-name (cadr l))
                         (slot-definition-location (car l)))))
              (mapcar #'slot-definition-location constrained-slots)))
          (local-index (class-instance-size class))
          (shared-index 0))
      ;; Actually the constrained-indices must form a list of consecutive indices
      ;; (1 2 ... n), but we don't need to make use of this.
      ;; Now determine the location of each slot.
      (when (and constrained-indices (< (first constrained-indices) local-index))
        (error (TEXT "In class ~S, a slot constrained from a superclass wants to be located at offset ~S, which is impossible.")
               (class-name class) (first constrained-indices)))
      (flet ((skip-constrained-indices ()
               (loop
                 (if (and constrained-indices
                          (= (first constrained-indices) local-index))
                   (progn (incf local-index) (pop constrained-indices))
                   (return)))))
        (skip-constrained-indices)
        (dolist (slot slots)
          (let ((name (slot-definition-name slot))
                (allocation (slot-definition-allocation slot)))
            (setf (slot-definition-location slot)
                  (cond ((eq allocation ':instance)
                         ;; Local slot.
                         (or (slot-definition-location slot)
                             (prog1
                               local-index
                               (incf local-index)
                               (skip-constrained-indices))))
                        ((eq allocation ':class)
                         ;; Shared slot.
                         ;; This is a flaw in the compute-slots protocol: the
                         ;; primary compute-slots method returns a list of slots,
                         ;; without information about the class where the slot
                         ;; comes from. So we have to re-scan the direct slots
                         ;; lists.
                         (let ((origin
                                 (dolist (superclass cpl class)
                                   (when (find name (class-direct-slots superclass)
                                               :key #'slot-definition-name)
                                     (return superclass)))))
                           (if (eq origin class)
                             ;; New shared slot.
                             (prog1
                               (cons (class-current-version class) shared-index)
                               (incf shared-index))
                             ;; Inherited shared slot.
                             (let ((inh-descriptor
                                     (gethash name (class-slot-location-table origin))))
                               (if (effective-slot-definition-p inh-descriptor)
                                 (slot-definition-location inh-descriptor)
                                 inh-descriptor)))))
                        (t ;; Don't signal an error for user-defined allocation
                           ;; types. They can be handled by user-defined around
                           ;; methods.
                           nil))))))
      ;; Actually the constrained-indices must already have been emptied by
      ;; the first (skip-constrained-indices) call, but we don't need to make
      ;; use of this. Warn if :fixed-slot-locations would cause a waste of
      ;; space.
      (when constrained-indices
        (setq local-index (1+ (car (last constrained-indices))))
        (clos-warning (TEXT "In class ~S, constrained slot locations cause holes to appear.")
          (class-name class)))
      slots)))

;; Preliminary.
(predefun compute-slots (class)
  (compute-slots-<slotted-class>-around class #'compute-slots-<defined-class>-primary))

(defun checked-compute-slots (class)
  (let ((slots (compute-slots class)))
    ; Some checks, to guarantee that user-defined around methods on
    ; compute-slots don't break our CLOS.
    (unless (proper-list-p slots)
      (error (TEXT "Wrong ~S result for class ~S: not a proper list: ~S")
             'compute-slots (class-name class) slots))
    (dolist (slot slots)
      (unless (standard-effective-slot-definition-p slot)
        (error (TEXT "Wrong ~S result for class ~S: list element is not a ~S: ~S")
               'compute-slots (class-name class)
               'standard-effective-slot-definition slot)))
    (unless (= (length slots)
               (length (delete-duplicates (mapcar #'slot-definition-name slots))))
      (error (TEXT "Wrong ~S result for class ~S: list contains duplicate slot names: ~S")
             'compute-slots (class-name class) slots))
    (dolist (slot slots)
      (case (slot-definition-allocation slot)
        ((:INSTANCE :CLASS)
         (unless (slot-definition-location slot)
           (error (TEXT "Wrong ~S result for class ~S: no slot location has been assigned to ~S")
                  'compute-slots (class-name class) slot)))))
    slots))

;; The MOP lacks a way to customize the instance size as a function of the
;; slots. This becomes an issue when you have slots which occupy more than one
;; word, and such a slot is the last local slot.
(defun compute-instance-size (class)
  (let ((size (class-instance-size class))) ; initial size depends on the metaclass
    (dolist (slot (class-slots class))
      (when (eq (slot-definition-allocation slot) ':instance)
        (let ((location (slot-definition-location slot)))
          (assert (integerp location))
          (setq size (max size (+ location 1))))))
    size))

;; Similarly, the MOP lacks a way to customize the shared slot values vector's
;; size as a function of the slots.
(defun compute-shared-size (class)
  (let ((shared-size 0))
    (dolist (slot (class-slots class))
      (let ((location (slot-definition-location slot)))
        (when (and (consp location) (eq (cv-newest-class (car location)) class))
          (let ((shared-index (cdr location)))
            (setq shared-size (max shared-size (+ shared-index 1)))))))
    shared-size))

;; Creates the shared slot values vector for a class.
(defun create-shared-slots-vector (class shared-size old-slot-location-table)
  (let ((v (make-array shared-size :initial-element 'DEADBEEF)))
    (dolist (slot (class-slots class))
      (let ((location (slot-definition-location slot)))
        (when (and (consp location)
                   (eq (cv-newest-class (car location)) class))
          (let ((shared-index (cdr location)))
            (setf (svref v shared-index)
                  (let* ((old-slot-descriptor
                           (gethash (slot-definition-name slot) old-slot-location-table))
                         (old-slot-location
                           (if (effective-slot-definition-p old-slot-descriptor)
                             (slot-definition-location old-slot-descriptor)
                             old-slot-descriptor)))
                    (if (and (consp old-slot-location)
                             (eq (cv-newest-class (car old-slot-location)) class))
                      ;; The slot was already shared. Retain its value.
                      (svref (cv-shared-slots (car old-slot-location))
                             (cdr old-slot-location))
                      ;; A new shared slot.
                      (let ((initfunction (slot-definition-initfunction slot)))
                        (if initfunction
                          (funcall initfunction)
                          (sys::%unbound))))))))))
    v))

(defun compute-slot-location-table (class)
  (let ((slots (class-slots class)))
    (if slots
      (make-hash-table
        :key-type 'symbol :value-type 't
        :test 'ext:stablehash-eq :warn-if-needs-rehash-after-gc t
        :initial-contents
          (mapcar #'(lambda (slot)
                      (cons (slot-definition-name slot)
                            (compute-slot-location-table-entry class slot)))
                  slots))
      empty-ht)))

(defun compute-slot-location-table-entry (class slot)
  (let ((location (slot-definition-location slot))
        ;; Compute the effective methods of SLOT-VALUE-USING-CLASS etc.
        ;; Note that we cannot use (class-prototype class) yet.
        ;; Also, SLOT-VALUE-USING-CLASS etc. are not defined on STRUCTURE-CLASS.
        (efm-svuc
          (if (and (semi-standard-class-p class) *classes-finished*)
            (compute-applicable-methods-effective-method-for-set
              |#'slot-value-using-class|
              (list `(EQL ,class) `(INSTANCE-OF-P ,class) `(EQL ,slot))
              (list class '`(CLASS-PROTOTYPE ,class) slot))
            #'%slot-value-using-class))
        (efm-ssvuc
          (if (and (semi-standard-class-p class) *classes-finished*)
            (compute-applicable-methods-effective-method-for-set
              |#'(setf slot-value-using-class)|
              (list `(TYPEP ,<t>) `(EQL ,class) `(INSTANCE-OF-P ,class) `(EQL ,slot))
              (list 'ANY-VALUE class '`(CLASS-PROTOTYPE ,class) slot))
            #'%set-slot-value-using-class))
        (efm-sbuc
          (if (and (semi-standard-class-p class) *classes-finished*)
            (compute-applicable-methods-effective-method-for-set
              |#'slot-boundp-using-class|
              (list `(EQL ,class) `(INSTANCE-OF-P ,class) `(EQL ,slot))
              (list class '`(CLASS-PROTOTYPE ,class) slot))
            #'%slot-boundp-using-class))
        (efm-smuc
          (if (and (semi-standard-class-p class) *classes-finished*)
            (compute-applicable-methods-effective-method-for-set
              |#'slot-makunbound-using-class|
              (list `(EQL ,class) `(INSTANCE-OF-P ,class) `(EQL ,slot))
              (list class '`(CLASS-PROTOTYPE ,class) slot))
            #'%slot-makunbound-using-class)))
    (setf (slot-definition-efm-svuc slot) efm-svuc)
    (setf (slot-definition-efm-ssvuc slot) efm-ssvuc)
    (setf (slot-definition-efm-sbuc slot) efm-sbuc)
    (setf (slot-definition-efm-smuc slot) efm-smuc)
    (if (and (eq efm-svuc #'%slot-value-using-class)
             (eq efm-ssvuc #'%set-slot-value-using-class)
             (eq efm-sbuc #'%slot-boundp-using-class)
             (eq efm-smuc #'%slot-makunbound-using-class))
      location
      slot)))

;; ----------------------------------------------------------------------------
;; CLtL2 28.1.3.3., ANSI CL 4.3.4.2. Inheritance of Default-Initargs

(defun compute-default-initargs-<defined-class> (class)
  (remove-duplicates
    (mapcap #'class-direct-default-initargs (class-precedence-list class))
    :key #'car
    :from-end t))

;; Preliminary.
(predefun compute-default-initargs (class)
  (compute-default-initargs-<defined-class> class))

(defun checked-compute-default-initargs (class)
  (let ((default-initargs (compute-default-initargs class)))
    ; Some checks, to guarantee that user-defined methods on
    ; compute-default-initargs don't break our CLOS.
    (unless (proper-list-p default-initargs)
      (error (TEXT "Wrong ~S result for class ~S: not a proper list: ~S")
             'compute-default-initargs (class-name class) default-initargs))
    (dolist (di default-initargs)
      (unless (canonicalized-default-initarg-p di)
        (error (TEXT "Wrong ~S result for class ~S: list element is not a canonicalized default initarg: ~S")
               'compute-default-initargs (class-name class) di)))
    (unless (= (length default-initargs)
               (length (delete-duplicates (mapcar #'first default-initargs))))
      (error (TEXT "Wrong ~S result for class ~S: list contains duplicate initarg names: ~S")
             'compute-default-initargs (class-name class) default-initargs))
    default-initargs))

;; ----------------------------- Accessor Methods -----------------------------

;; Flag to avoid bootstrapping issues with the compiler.
(defvar *compile-accessor-functions* nil)

(defun check-method-redefinition (funname qualifiers spec-list caller)
  (sys::check-redefinition
   (list* funname qualifiers spec-list) caller
   ;; do not warn about redefinition when no method was defined
   (and (fboundp 'find-method) (fboundp funname)
        (typep-class (fdefinition funname) <generic-function>)
        (not (safe-gf-undeterminedp (fdefinition funname)))
        (eql (sig-req-num (safe-gf-signature (fdefinition funname)))
             (length spec-list))
        (find-method (fdefinition funname) qualifiers spec-list nil)
        (TEXT "method"))))

;; Install the accessor methods corresponding to the direct slots of a class.
(defun install-class-direct-accessors (class)
  (dolist (slot (class-direct-slots class))
    (let ((slot-name (slot-definition-name slot))
          (readers (slot-definition-readers slot))
          (writers (slot-definition-writers slot)))
      (when (or readers writers)
        (let ((generic-p (class-generic-accessors class))
              (access-place
                (let (effective-slot)
                  (if (and (semi-standard-class-p class)
                           (class-fixed-slot-locations class)
                           (setq effective-slot
                                 (find slot-name (class-slots class)
                                       :key #'slot-definition-name))
                           (eq (slot-definition-allocation effective-slot)
                               ':instance))
                    (progn
                      (assert (typep (slot-definition-location effective-slot) 'integer))
                      `(STANDARD-INSTANCE-ACCESS OBJECT ,(slot-definition-location effective-slot)))
                    (if (and (structure-class-p class)
                             (setq effective-slot
                                   (find slot-name (class-slots class)
                                         :key #'slot-definition-name))
                             (eq (slot-definition-allocation effective-slot)
                                 ':instance))
                      (progn
                        (assert (typep (slot-definition-location effective-slot) 'integer))
                        `(SYSTEM::%STRUCTURE-REF ',(class-name class) OBJECT ,(slot-definition-location effective-slot)))
                      `(SLOT-VALUE OBJECT ',slot-name))))))
          ;; Generic accessors are defined as methods and listed in the
          ;; direct-accessors list, so they can be removed upon class redefinition.
          ;; Non-generic accessors are defined as plain functions.
          ;; Call CHECK-REDEFINITION appropriately.
          (dolist (funname readers)
            (if generic-p
              (progn
                (check-method-redefinition funname nil (list class) 'defclass)
                (setf (class-direct-accessors class)
                      (list* funname
                             (do-defmethod funname
                               (let* ((args
                                       (list
                                        :specializers (list class)
                                        :qualifiers nil
                                        :lambda-list '(OBJECT)
                                        'signature (sys::memoized (make-signature :req-num 1))
                                        :slot-definition slot))
                                      (method-class
                                       (apply #'reader-method-class
                                              class slot args)))
                                 (unless (and (defined-class-p method-class)
                                              (subclassp method-class <standard-reader-method>))
                                   (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S")
                                          'reader-method-class (class-name class) 'standard-reader-method method-class))
                                 (apply #'make-instance method-class
                                        (nconc (method-function-initargs
                                                method-class
                                                (eval
                                                 `(LOCALLY
                                                      (DECLARE (COMPILE))
                                                    (%OPTIMIZE-FUNCTION-LAMBDA
                                                     (T) (#:CONTINUATION OBJECT)
                                                     (DECLARE (COMPILE))
                                                     ,access-place))))
                                               args))))
                             (class-direct-accessors class))))
              (progn
                (sys::check-redefinition
                 funname 'defclass (sys::fbound-string funname))
                (setf (fdefinition funname)
                      (eval `(FUNCTION ,funname (LAMBDA (OBJECT)
                               ,@(if *compile-accessor-functions* '((DECLARE (COMPILE))))
                               (UNLESS (TYPEP OBJECT ',class)
                                 (ERROR-ACCESSOR-TYPECHECK ',funname OBJECT ',class))
                               ,access-place)))))))
          (dolist (funname writers)
            (if generic-p
              (progn
                (check-method-redefinition funname nil (list class) 'defclass)
                (setf (class-direct-accessors class)
                      (list* funname
                             (do-defmethod funname
                               (let* ((args
                                       (list
                                        :specializers (list <t> class)
                                        :qualifiers nil
                                        :lambda-list '(NEW-VALUE OBJECT)
                                        'signature (sys::memoized (make-signature :req-num 2))
                                        :slot-definition slot))
                                      (method-class
                                       (apply #'writer-method-class
                                              class slot args)))
                                 (unless (and (defined-class-p method-class)
                                              (subclassp method-class <standard-writer-method>))
                                   (error (TEXT "Wrong ~S result for class ~S: not a subclass of ~S: ~S")
                                          'writer-method-class
                                          (class-name class)
                                          'standard-writer-method method-class))
                                 (apply #'make-instance method-class
                                        (nconc (method-function-initargs
                                                method-class
                                                (eval
                                                 `(LOCALLY
                                                      (DECLARE (COMPILE))
                                                    (%OPTIMIZE-FUNCTION-LAMBDA
                                                     (T) (#:CONTINUATION NEW-VALUE OBJECT)
                                                     (DECLARE (COMPILE))
                                                     (SETF ,access-place NEW-VALUE)))))
                                               args))))
                             (class-direct-accessors class))))
              (progn
                (sys::check-redefinition
                 funname 'defclass (sys::fbound-string
                                    (sys::get-funname-symbol funname)))
                (setf (fdefinition funname)
                      (eval `(FUNCTION ,funname (LAMBDA (NEW-VALUE OBJECT)
                               ,@(if *compile-accessor-functions* '((DECLARE (COMPILE))))
                               (UNLESS (TYPEP OBJECT ',class)
                                 (ERROR-ACCESSOR-TYPECHECK ',funname OBJECT ',class))
                               (SETF ,access-place NEW-VALUE)))))))))))))

;; Remove a set of accessor methods given as a plist.
(defun remove-accessor-methods (plist)
  (do ((l plist (cddr l)))
      ((endp l))
    (let ((funname (car l))
          (method (cadr l)))
      (remove-method (fdefinition funname) method))))

;; Add a set of accessor methods given as a plist.
(defun add-accessor-methods (plist)
  (do ((l plist (cddr l)))
      ((endp l))
    (let ((funname (car l))
          (method (cadr l)))
      (add-method (fdefinition funname) method))))

;; --------------- Creation of an instance of <built-in-class> ---------------

(defun make-instance-<built-in-class> (metaclass &rest args
                                       &key name (direct-superclasses '())
                                       &allow-other-keys)
  ;; metaclass = <built-in-class>
  ;; Don't add functionality here! This is a preliminary definition that is
  ;; replaced with #'make-instance later.
  (declare (ignore metaclass name direct-superclasses))
  (let ((class (allocate-metaobject-instance *<built-in-class>-class-version*
                                             *<built-in-class>-instance-size*)))
    (apply #'initialize-instance-<built-in-class> class args)))

(defun initialize-instance-<built-in-class> (class &rest args
                                             &key &allow-other-keys)
  ;; Don't add functionality here! This is a preliminary definition that is
  ;; replaced with #'initialize-instance later.
  (apply #'shared-initialize-<built-in-class> class 't args)
  (install-class-direct-accessors class)
  class)

(defun shared-initialize-<built-in-class> (class situation &rest args
                                           &key (name nil name-p)
                                                (direct-superclasses '() direct-superclasses-p)
                                                ((prototype prototype) nil prototype-p)
                                           &allow-other-keys)
  (when (or (eq situation 't) direct-superclasses-p)
    (check-metaclass-mix (if name-p name (class-classname class))
                         direct-superclasses
                         #'built-in-class-p 'built-in-class))
  (apply #'shared-initialize-<defined-class> class situation args)
  ; Initialize the remaining <defined-class> slots:
  (when (or (eq situation 't) direct-superclasses-p)
    (setf (class-precedence-list class)
          (checked-compute-class-precedence-list class))
    (when (eq situation 't)
      (setf (class-initialized class) 3))
    (setf (class-all-superclasses class)
          (std-compute-superclasses (class-precedence-list class)))
    (when (eq situation 't)
      (setf (class-initialized class) 4)))
  (when (eq situation 't)
    (setf (class-slots class) '())
    (setf (class-initialized class) 5)
    (setf (class-default-initargs class) '())
    (setf (class-initialized class) 6))
  (when (or (eq situation 't) prototype-p)
    (setf (sys::%record-ref class *<built-in-class>-prototype-location*) prototype))
  ; Done.
  class)

;; --------------- Creation of an instance of <structure-class> ---------------

(defun make-instance-<structure-class> (metaclass &rest args
                                        &key name (direct-superclasses '())
                                             ;; The following keys come from ENSURE-CLASS.
                                             ((:direct-slots direct-slots-as-lists) '())
                                             (direct-default-initargs '()) (documentation nil)
                                             ;; The following keys come from DEFINE-STRUCTURE-CLASS.
                                             ((names names) nil)
                                             ((kconstructor kconstructor) nil)
                                             ((boa-constructors boa-constructors) '())
                                             ((copier copier) nil)
                                             ((predicate predicate) nil)
                                             ((direct-slots direct-slots-as-metaobjects) '())
                                             ((slots slots) '()) ((size size) 1)
                                        &allow-other-keys)
  ;; metaclass = <structure-class>
  ;; Don't add functionality here! This is a preliminary definition that is
  ;; replaced with #'make-instance later.
  (declare (ignore metaclass name direct-superclasses direct-slots-as-lists
                   direct-default-initargs documentation
                   names kconstructor boa-constructors copier predicate
                   direct-slots-as-metaobjects slots size))
  (let ((class (allocate-metaobject-instance *<structure-class>-class-version*
                                             *<structure-class>-instance-size*)))
    (apply #'initialize-instance-<structure-class> class args)))

(defun initialize-instance-<structure-class> (class &rest args
                                              &key &allow-other-keys)
  ;; Don't add functionality here! This is a preliminary definition that is
  ;; replaced with #'initialize-instance later.
  (apply #'shared-initialize-<structure-class> class 't args)
  ;; avoid slot accessor redefinition warning
  ;; (install-class-direct-accessors class)
  class)

(defun shared-initialize-<structure-class> (class situation &rest args
                                            &key (name nil name-p)
                                                 (direct-superclasses '() direct-superclasses-p)
                                                 (generic-accessors t generic-accessors-p)
                                                 ;; The following keys come from ENSURE-CLASS.
                                                 ((:direct-slots direct-slots-as-lists) '() direct-slots-as-lists-p)
                                                 (direct-default-initargs '() direct-default-initargs-p)
                                                 (documentation nil documentation-p)
                                                 ;; The following keys come from DEFINE-STRUCTURE-CLASS.
                                                 ((names names) nil names-p)
                                                 ((kconstructor kconstructor) nil kconstructor-p)
                                                 ((boa-constructors boa-constructors) '() boa-constructors-p)
                                                 ((copier copier) nil copier-p)
                                                 ((predicate predicate) nil predicate-p)
                                                 ((direct-slots direct-slots-as-metaobjects) '() direct-slots-as-metaobjects-p)
                                                 ((slots slots) '())
                                                 ((size size) 1)
                                            &allow-other-keys)
  ;; metaclass ⊆ <structure-class>
  (declare (ignore generic-accessors generic-accessors-p direct-slots-as-lists
                   direct-slots-as-metaobjects direct-default-initargs
                   documentation documentation-p))
  (when (or (eq situation 't) direct-superclasses-p)
    (check-metaclass-mix (if name-p name (class-classname class))
                         direct-superclasses
                         #'structure-class-p 'STRUCTURE-CLASS))
  (apply #'shared-initialize-<slotted-class> class situation args)
  (setq direct-superclasses (class-direct-superclasses class)) ; augmented
  ; Initialize the remaining <defined-class> slots:
  (when (or (eq situation 't) direct-superclasses-p)
    (setf (class-precedence-list class)
          (checked-compute-class-precedence-list class))
    (when (eq situation 't)
      (setf (class-initialized class) 3))
    (setf (class-all-superclasses class)
          (std-compute-superclasses (class-precedence-list class)))
    (when (eq situation 't)
      (setf (class-initialized class) 4)))
  (when (or (eq situation 't) direct-superclasses-p
            direct-slots-as-lists-p direct-slots-as-metaobjects-p)
    (setf (class-slots class) slots)
    (when (eq situation 't)
      (setf (class-initialized class) 5))
    (setf (class-slot-location-table class) (compute-slot-location-table class))
    (setf (class-instance-size class) size)
    (unless names
      (setf (class-instance-size class) 1)
      (setf (class-slots class)
            (compute-slots-<slotted-class>-around class #'compute-slots-<defined-class>-primary))
      (setf (class-instance-size class) (max size (compute-instance-size class)))
      (when (class-slots class)
        (let ((ht (class-slot-location-table class)))
          (when (eq ht empty-ht) ; avoid clobbering empty-ht!
            (setq ht (setf (class-slot-location-table class)
                           (make-hash-table
                             :key-type 'symbol :value-type 't
                             :test 'ext:stablehash-eq :warn-if-needs-rehash-after-gc t))))
          (dolist (slot (class-slots class))
            (setf (gethash (slot-definition-name slot) ht)
                  (slot-definition-location slot)))))
      (when (plusp (compute-shared-size class))
        (error-of-type 'error
          (TEXT "(~S ~S): metaclass ~S does not support shared slots")
                'DEFCLASS name 'STRUCTURE-CLASS))))
  (when (or (eq situation 't) direct-superclasses-p direct-default-initargs-p)
    (setf (class-default-initargs class)
          (checked-compute-default-initargs class)))
  (when (eq situation 't)
    (setf (class-initialized class) 6))
  ; Initialize the remaining <slotted-class> slots:
  (when (or (eq situation 't) direct-superclasses-p)
    (setf (class-subclass-of-stablehash-p class)
          (std-compute-subclass-of-stablehash-p class)))
  (when (or (eq situation 't) direct-superclasses-p
            direct-slots-as-lists-p direct-slots-as-metaobjects-p)
    (setf (class-valid-initargs-from-slots class)
          (remove-duplicates (mapcap #'slot-definition-initargs (class-slots class)))))
  ; Initialize the remaining <structure-class> slots:
  (when (or (eq situation 't) direct-superclasses-p names-p)
    (unless names
      (setq names
            (cons name
                  (if direct-superclasses
                     (class-names (first direct-superclasses))
                     '()))))
    (setf (class-names class) names))
  (when (or (eq situation 't) kconstructor-p)
    (setf (class-kconstructor class) kconstructor))
  (when (or (eq situation 't) boa-constructors-p)
    (setf (class-boa-constructors class) boa-constructors))
  (when (or (eq situation 't) copier-p)
    (setf (class-copier class) copier))
  (when (or (eq situation 't) predicate-p)
    (setf (class-predicate class) predicate))
  (when (eq situation 't)
    (setf (sys::%record-ref class *<structure-class>-prototype-location*) nil))
  ; Done.
  (when (eq situation 't)
    (system::note-new-structure-class))
  class)

;; DEFSTRUCT-Hook
(defun define-structure-class (name names keyword-constructor boa-constructors copier predicate all-slots direct-slots) ; ABI
  (setf (find-class name)
        (make-instance-<structure-class> <structure-class>
          :name name
          :direct-superclasses
            (if (cdr names) (list (find-class (second names))) '())
          'names names
          'kconstructor keyword-constructor
          'boa-constructors boa-constructors
          'copier copier
          'predicate predicate
          'direct-slots direct-slots
          'slots all-slots
          'size (if all-slots
                  (1+ (slot-definition-location (car (last all-slots))))
                  1)
          :generic-accessors nil
          'clos::defclass-form 'defstruct)))
(defun undefine-structure-class (name) ; ABI
  (setf (find-class name) nil))

;; ------------- Creation of an instance of <semi-standard-class> -------------

(defun shared-initialize-<semi-standard-class> (class situation &rest args
                                                &key (direct-superclasses '() direct-superclasses-p)
                                                     ((:direct-slots direct-slots-as-lists) '() direct-slots-as-lists-p)
                                                     ((direct-slots direct-slots-as-metaobjects) '() direct-slots-as-metaobjects-p)
                                                     (direct-default-initargs '() direct-default-initargs-p)
                                                     (documentation nil documentation-p)
                                                     (generic-accessors t generic-accessors-p)
                                                     (fixed-slot-locations nil fixed-slot-locations-p)
                                                &allow-other-keys)
  (declare (ignore direct-superclasses direct-superclasses-p
                   direct-slots-as-lists direct-slots-as-lists-p
                   direct-slots-as-metaobjects direct-slots-as-metaobjects-p
                   direct-default-initargs direct-default-initargs-p
                   documentation documentation-p generic-accessors
                   generic-accessors-p))
  (apply #'shared-initialize-<slotted-class> class situation args)
  (when (eq situation 't)
    (setf (class-current-version class)
          (make-class-version :newest-class class
                              :class class
                              :serial 0))
    (unless *classes-finished*
      ; Bootstrapping: Simulate the effect of #'%shared-initialize.
      (setf (class-instantiated class) nil)
      (setf (class-direct-instance-specializers-table class) '())
      (setf (class-finalized-direct-subclasses-table class) '())))
  ; Initialize the remaining <defined-class> slots:
  (setf (class-initialized class) 2) ; mark as not yet finalized
  (setf (class-precedence-list class) nil) ; mark as not yet finalized
  (setf (class-all-superclasses class) nil) ; mark as not yet finalized
  ; Initialize the remaining <slotted-class> slots:
  ; Initialize the remaining <semi-standard-class> slots:
  (when (or (eq situation 't) fixed-slot-locations-p)
    ;; Convert from list to boolean.
    (when (consp fixed-slot-locations)
      (setq fixed-slot-locations (car fixed-slot-locations)))
    (setf (class-fixed-slot-locations class) fixed-slot-locations))
  (setf (class-prototype class) nil)
  ; Try to finalize it.
  (when (finalizable-p class)
    (finalize-inheritance class))
  ; Done.
  class)

;; ------------- Finalizing an instance of <semi-standard-class> -------------

;; Tests whether a class can be finalized, by recursing on the
;; direct-superclasses list. May call finalize-inheritance on some of the
;; superclasses.
;; Returns T if all the direct-superclasses could be finalized.
;; Returns NIL if this is not possible, and as second value a list from the
;; direct-superclass that couldn't be finalized up to the forward-reference
;; that is not yet defined.
(defun finalizable-p (class &optional (stack nil))
  (assert (defined-class-p class))
  (when (memq class stack)
    (error-of-type 'program-error
      (TEXT "~S: class definition circularity: ~S depends on itself")
      'defclass class))
  (let ((stack (cons class stack)))
    (do ((superclassesr (class-direct-superclasses class) (cdr superclassesr)))
        ((endp superclassesr))
      (let ((superclass (car superclassesr)))
        (unless (defined-class-p superclass)
          (unless (forward-reference-to-class-p superclass)
            (error (TEXT "~S has a direct-superclasses element ~S, which is invalid.")
                   class superclass))
          (let ((real-superclass
                  (or (find-class (class-name superclass) nil)
                      (return-from finalizable-p (values nil (list superclass))))))
            ;; Changed from forward-reference-to-class to defined-class.
            (check-allowed-superclass class real-superclass)
            (setf (car superclassesr) real-superclass)
            (remove-direct-subclass superclass class)
            (add-direct-subclass real-superclass class)
            (setq superclass real-superclass)))
        (assert (defined-class-p superclass))
        (unless (>= (class-initialized superclass) 6) ; not already finalized?
          ;; Here we get only for instances of STANDARD-CLASS, since instances
          ;; of BUILT-IN-CLASS and STRUCTURE-CLASS are already finalized when
          ;; they are constructed.
          (multiple-value-bind (done failure-cause) (finalizable-p superclass stack)
            (unless done
              ;; Finalization of a superclass was impossible.
              (return-from finalizable-p (values nil (cons superclass failure-cause)))))
          ;; Now finalize the superclass. (We could also do this later, from
          ;; inside finalize-inheritance, but then we would need some extra
          ;; bookkeeping to ensure that the running time for a class hierarchy
          ;; like this
          ;;                     A1
          ;;                    /  \
          ;;                   B1  C1
          ;;                    \  /
          ;;                     A2
          ;;                    /  \
          ;;                   B2  C2
          ;;                    \  /
          ;;                     A3
          ;;                    ....
          ;;                   A(n-1)
          ;;                    /  \
          ;;                B(n-1) C(n-1)
          ;;                    \  /
          ;;                     An
          ;; is linear, not exponential, in the number of classes.)
          (finalize-inheritance superclass)))))
  t)

;; Preliminary.
(predefun finalize-inheritance (class)
  (finalize-inheritance-<semi-standard-class> class))

(defun finalize-inheritance-<semi-standard-class> (class)
  (multiple-value-bind (done failure-cause) (finalizable-p class)
    (unless done
      (let ((pretty-cause (mapcar #'class-pretty (cons class failure-cause))))
        (error (TEXT "~S: Cannot finalize class ~S. ~:{Class ~S inherits from class ~S. ~}Class ~S is not yet defined.")
               'finalize-inheritance (first pretty-cause)
               (mapcar #'list pretty-cause (rest pretty-cause))
               (car (last pretty-cause))))))
  ;; Now we know that all direct superclasses are finalized.
  (when (boundp 'class-finalized-p)
    (assert (every #'class-finalized-p (class-direct-superclasses class))))
  ;; Now compute the class-precedence-list.
  (finalize-instance-semi-standard-class class)
  class)

(defun finalize-instance-semi-standard-class (class
       &aux (direct-superclasses (class-direct-superclasses class))
            (name (class-name class))
            (old-slot-location-table (class-slot-location-table class)))
  ;; metaclass ⊆ <semi-standard-class>
  (if (standard-class-p class)
    (check-metaclass-mix name direct-superclasses
                         #'standard-class-p 'STANDARD-CLASS)
    (check-metaclass-mix name direct-superclasses
                         #'semi-standard-class-p 'SEMI-STANDARD-CLASS))
  (setf (class-precedence-list class)
        (checked-compute-class-precedence-list class))
  (when (< (class-initialized class) 3)
    (setf (class-initialized class) 3))
  (setf (class-all-superclasses class)
        (std-compute-superclasses (class-precedence-list class)))
  (when (< (class-initialized class) 4)
    (setf (class-initialized class) 4))
  (dolist (super direct-superclasses)
    (when (semi-standard-class-p super)
      (add-finalized-direct-subclass super class)))
  (setf (class-subclass-of-stablehash-p class)
        (std-compute-subclass-of-stablehash-p class))
  (setf (class-funcallablep class)
        ; <funcallable-standard-object> or a subclass of it?
        (if (gethash <function> (class-all-superclasses class)) t nil))
  (setf (class-instance-size class)
        (if (class-funcallablep class)
          3  ; see comments in clos-genfun1.lisp
          1)) ; slot 0 is the class_version pointer
  (setf (class-slots class) (checked-compute-slots class))
  (when (< (class-initialized class) 5)
    (setf (class-initialized class) 5))
  (setf (class-instance-size class) (compute-instance-size class))
  (setf (class-slot-location-table class) (compute-slot-location-table class))
  (let ((shared-size (compute-shared-size class)))
    (when (plusp shared-size)
      (setf (cv-shared-slots (class-current-version class))
            (create-shared-slots-vector class shared-size old-slot-location-table))))
  ;; CLtL2 28.1.3.3., ANSI CL 4.3.4.2. Inheritance of Class Options
  (setf (class-default-initargs class) (checked-compute-default-initargs class))
  (setf (class-valid-initargs-from-slots class)
        (remove-duplicates (mapcap #'slot-definition-initargs (class-slots class))))
  (when (< (class-initialized class) 6)
    (setf (class-initialized class) 6))
  (system::note-new-standard-class))

;; ------------- Redefining an instance of <semi-standard-class> -------------

;; Preliminary definition.
(predefun make-instances-obsolete (class)
  (make-instances-obsolete-<semi-standard-class> class))

(defun make-instances-obsolete-<semi-standard-class> (class)
  (when (>= (class-initialized class) 6) ; nothing to do if not yet finalized
    ;; Recurse to the subclasses. (Even if there are no direct instances of
    ;; this class: the subclasses may have instances.)
    (mapc #'make-instances-obsolete-<semi-standard-class>-nonrecursive
          (list-all-finalized-subclasses class))))

(defun make-instances-obsolete-<semi-standard-class>-nonrecursive (class)
  (if (and (>= (class-initialized class) 4) ; already finalized?
           (subclassp class <metaobject>))
    ; Don't obsolete metaobject instances.
    (let ((name (class-name class))
          (caller *make-instances-obsolete-caller*)
          ;; Rebind *make-instances-obsolete-caller* because WARN may enter a
          ;; nested REP-loop.
          (*make-instances-obsolete-caller* 'make-instances-obsolete))
      (clos-warning (TEXT "~S: Class ~S (or one of its ancestors) is being redefined, but its instances cannot be made obsolete")
        caller name))
    (progn
      (when (class-instantiated class) ; don't warn if there are no instances
        (let ((name (class-name class))
              (caller *make-instances-obsolete-caller*)
              ;; Rebind *make-instances-obsolete-caller* because WARN may enter a
              ;; nested REP-loop.
              (*make-instances-obsolete-caller* 'make-instances-obsolete))
          (if (eq caller 'defclass)
            (clos-warning (TEXT "~S: Class ~S (or one of its ancestors) is being redefined, instances are obsolete")
              caller name)
            (clos-warning (TEXT "~S: instances of class ~S are made obsolete")
              caller name))))
      ;; Create a new class-version. (Even if there are no instances: the
      ;; shared-slots may need change.)
      (let* ((copy (copy-standard-class class))
             (old-version (class-current-version copy))
             (new-version
               (make-class-version :newest-class class
                                   :class class
                                   :serial (1+ (cv-serial old-version)))))
        (setf (cv-class old-version) copy)
        (setf (cv-next old-version) new-version)
        (setf (class-current-version class) new-version)))))

;; After a class redefinition, finalize the subclasses so that the instances
;; can be updated.
(defun update-subclasses-for-redefined-class (class was-finalized must-be-finalized old-direct-superclasses)
  (when was-finalized ; nothing to do if not finalized before the redefinition
    ;; Handle the class itself specially, because its superclasses list now is
    ;; not the same as before.
    (setf (class-initialized class) 2) ; mark as not yet finalized
    (setf (class-precedence-list class) nil) ; mark as not yet finalized
    (setf (class-all-superclasses class) nil) ; mark as not yet finalized
    (if must-be-finalized
      ;; The class remains finalized.
      (progn
        (finalize-inheritance class)
        (let ((new-direct-superclasses (class-direct-superclasses class)))
          (unless (equal old-direct-superclasses new-direct-superclasses)
            (let ((removed-direct-superclasses
                    (set-difference old-direct-superclasses new-direct-superclasses))
                  (added-direct-superclasses
                    (set-difference new-direct-superclasses old-direct-superclasses)))
              (dolist (super removed-direct-superclasses)
                (when (semi-standard-class-p super)
                  (remove-finalized-direct-subclass super class)))
              (dolist (super added-direct-superclasses)
                (when (semi-standard-class-p super)
                  (add-finalized-direct-subclass super class)))))))
      ;; The class becomes unfinalized.
      (dolist (super old-direct-superclasses)
        (when (semi-standard-class-p super)
          (remove-finalized-direct-subclass super class))))
    ;; Now handle the true subclasses.
    (mapc #'update-subclasses-for-redefined-class-nonrecursive
          (rest (list-all-finalized-subclasses class)))))

(defun update-subclasses-for-redefined-class-nonrecursive (class)
  (when (>= (class-initialized class) 6) ; nothing to do if not yet finalized
    (setf (class-initialized class) 2) ; mark as not yet finalized
    (setf (class-precedence-list class) nil) ; mark as not yet finalized
    (setf (class-all-superclasses class) nil) ; mark as not yet finalized
    (if (class-instantiated class)
      ;; The class remains finalized.
      (finalize-inheritance class)
      ;; The class becomes unfinalized. If it has an instantiated subclass, the
      ;; subclass' finalize-inheritance invocation will re-finalize this one.
      (dolist (super (class-direct-superclasses class))
        (when (semi-standard-class-p super)
          (remove-finalized-direct-subclass super class))))))

;; After a class redefinition that changed the class-precedence-list,
;; update the generic functions that use specializers whose object is a
;; direct instance of this class or of a subclass.
(defun update-subclass-instance-specializer-generic-functions (class)
  (dolist (subclass (list-all-finalized-subclasses class))
    ;; Since the CPL of the class has changed, the CPL of the subclass has
    ;; most likely changed as well. It is not worth testing whether it has
    ;; really changed.
    (dolist (specializer (list-direct-instance-specializers subclass))
      ;; specializer's location in the type hierarchy has now changed.
      (dolist (gf (specializer-direct-generic-functions specializer))
        (when (typep-class gf <standard-generic-function>)
          ;; Clear the discriminating function.
          ;; The effective method cache does not need to be invalidated.
          #|(setf (std-gf-effective-method-cache gf) '())|#
          (finalize-fast-gf gf))))))

;; After a class redefinition that changed the class-precedence-list,
;; update the generic functions that could be affected.
(defun update-subclass-cpl-specializer-generic-functions (class old-cpl new-cpl)
  ;; Class definitions change the type hierarchy, therefore the discriminating
  ;; function of some generic functions has to be invalidated and recomputed
  ;; later.
  ;; The effective method cache does not need to be invalidated, since it takes
  ;; a sorted method list as input and compute-effective-method-as-function
  ;; doesn't do computations in the type hierarchy.
  ;;
  ;; Now, which generic functions are affected? The discriminating function of
  ;; a generic depends on the following. (x denotes an object occurring as
  ;; argument, and x-class means (class-of x).)
  ;; 1. The computation of the applicable method list for given arguments x
  ;;    depends on
  ;;      (subclassp x-class specializer)
  ;;    for all specializers occurring in methods of the GF.
  ;; 2. The discriminating function is also free to exploit the result of
  ;;      (subclassp specializer1 specializer2)
  ;;    for any two specializer1, specializer2 occurring in methods of the GF.
  ;; 3. The sorting of the applicable method list for given arguments x
  ;;    depends on the relative order of specializer1 and specializer2 in
  ;;    (cpl x-class), for any two specializer1, specializer2 occurring in
  ;;    methods of the GF.
  ;;
  ;; What effects can a change of (cpl class) = old-cpl -> new-cpl have?
  ;; Assume that some classes S+ are added, some classes S- are removed from
  ;; the CPL, and some classes S* are reordered in the CPL. What effects does
  ;; this have on (cpl o-class), where o-class is any other class?
  ;; - If o-class is not a subclass of class, (cpl o-class) doesn't change.
  ;; - If o-class if subclass of class,
  ;;     the elements of S+ are added or, if already present, possibly
  ;;     reordered,
  ;;     the elements of S- are possibly removed or reordered,
  ;;     the elements of S* are possibly reordered.
  ;;   ("Possibly" because o-class can also inherit from other classes that
  ;;   are not under the given class but under elements of S+, S-, S*.)
  ;;
  ;; Now back to the problem of finding the affected generic functions.
  ;; 1. (subclassp x-class specializer) == (member specializer (cpl x-class))
  ;;    - doesn't change if x-class is not a subclass of class,
  ;;    - doesn't change if specializer is not an element of S+ or S-.
  ;;    Because of the implicit "for all x", we cannot exploit the first
  ;;    statement. But the second statement tells us that we have to go
  ;;    from the elements of S+ and S- to the methods and generic functions
  ;;    using these classes as specializers.
  ;; 2. (subclassp specializer1 specializer2)
  ;;    == (member specializer2 (cpl specializer1))
  ;;    - doesn't change if specializer1 is not a subclass of class,
  ;;    - doesn't change if specializer2 is not an element of S+ or S-.
  ;;    So we have to intersect
  ;;    - the set of GFs using a subclass of class as specializer,
  ;;    - the set of GFs using an element of S+ or S- as specializer.
  ;;    This is a subset of the one we got in point 1. It is redundant.
  ;; 3. We know that if
  ;;          old (cpl x-class) = (... specializer1 ... specializer2 ...)
  ;;    and   new (cpl x-class) = (... specializer2 ... specializer1 ...)
  ;;    then x-class is a subclass of the given class, and one of
  ;;    specializer1, specializer2 (at least) is a member of S+, S- or S*.
  ;;    Because of the implicit "for all x", the first condition is hard to
  ;;    exploit: we need to recurse through all x-class that are subclasses
  ;;    the given class. It is easier to exploit the second condition:
  ;;    Go from the elements of S+, S-, S* to the methods and generic functions
  ;;    using these classes as specializers.
  ;;
  ;; Cf. MOP p. 41 compute-discriminating-function item (iv). This says that
  ;; all generic functions which use a specializer whose class precedence list
  ;; has changed (i.e. essentially a specializer which is a subclass of the
  ;; given class) should invalidate their discriminating function. This is not
  ;; needed!
  ;;
  ;; Cf. MOP p. 41 compute-discriminating-function item (v). This says that
  ;; all generic functions which have a cache entry containing a class whose
  ;; class precedence list has changed (i.e. essentially a subclass of the
  ;; given class) should invalidate their discriminating function. This is
  ;; also far more than is needed; all that's needed is 1. and 3.
  ;;
  (declare (ignore class))
  (let* ((added-superclasses (set-difference new-cpl old-cpl))
         (removed-superclasses (set-difference old-cpl new-cpl))
         (permuted-superclasses
           (let ((common-superclasses-in-old-order
                   (remove-if #'(lambda (x) (memq x removed-superclasses))
                              (the list old-cpl)))
                 (common-superclasses-in-new-order
                   (remove-if #'(lambda (x) (memq x added-superclasses))
                              (the list new-cpl))))
             (assert (= (length common-superclasses-in-old-order)
                        (length common-superclasses-in-new-order)))
             (subseq common-superclasses-in-old-order
                     0
                     (or (mismatch common-superclasses-in-old-order
                                   common-superclasses-in-new-order
                                   :test #'eq
                                   :from-end t)
                         0)))))
    ;; Build the set of affected generic functions.
    (let ((gf-set
            (make-hash-table :key-type 'generic-function :value-type '(eql t)
                             :test 'ext:fasthash-eq)))
      (dolist (specializer (append added-superclasses removed-superclasses
                                   permuted-superclasses))
        (dolist (gf (specializer-direct-generic-functions specializer))
          (setf (gethash gf gf-set) t)))
      #|
      (format *debug-io* "~&added = ~:S, removed = ~:S, permuted = ~:S, affected = ~:S~%"
                         added-superclasses removed-superclasses permuted-superclasses
                         (let ((l '()))
                           (maphash #'(lambda (gf ignored)
                                        (declare (ignore ignored))
                                        (push gf l))
                                    gf-set)
                           l))
      |#
      ;; Clear their discriminating function.
      (maphash #'(lambda (gf ignored)
                   (declare (ignore ignored))
                   (when (typep-class gf <standard-generic-function>)
                     (finalize-fast-gf gf)))
               gf-set))))

;; Store the information needed by the update of obsolete instances in a
;; class-version object. Invoked when an instance needs to be updated.
(defun class-version-compute-slotlists (old-version)
  (let ((old-class (cv-class old-version))
        (new-class (cv-class (cv-next old-version)))
        ; old-class is already finalized - otherwise no instance could exist.
        ; new-class is already finalized, because ensure-class guarantees it.
        (kept2 '())
        (added '())
        (discarded '())
        (discarded2 '()))
    (dolist (old-slot (class-slots old-class))
      (let* ((name (slot-definition-name old-slot))
             (new-slot (find name (class-slots new-class)
                             :test #'eq :key #'slot-definition-name)))
        (if (and new-slot (atom (slot-definition-location new-slot)))
          ;; Local slot remains local, or shared slot becomes local.
          (setq kept2 (list* (slot-definition-location old-slot)
                             (slot-definition-location new-slot)
                             kept2))
          (if (atom (slot-definition-location old-slot))
            ;; Local slot is discarded or becomes shared.
            (setq discarded (cons name discarded)
                  discarded2 (list* name (slot-definition-location old-slot) discarded2))))))
    (dolist (new-slot (class-slots new-class))
      (let* ((name (slot-definition-name new-slot))
             (old-slot (find name (class-slots old-class)
                             :test #'eq :key #'slot-definition-name)))
        (unless old-slot
          ;; Newly added local slot.
          (setq added (cons name added)))))
    (setf (cv-kept-slot-locations old-version) kept2)
    (setf (cv-added-slots old-version) added)
    (setf (cv-discarded-slots old-version) discarded)
    (setf (cv-discarded-slot-locations old-version) discarded2)
    (setf (cv-slotlists-valid-p old-version) t)))

;; -------------- Auxiliary functions for <semi-standard-class> --------------

;;; Maintaining the list of eql-specializers of direct instances that are or
;;; were used in a method. (We need this for notifying the generic functions
;;; to which these methods belong, when the class or a superclass of it is
;;; redefined in a way that changes the class-precedence-list.)

#|
;; Adds a class to the list of direct instance specializers.
(defun add-direct-instance-specializer (class eql-specializer) ...)
;; Removes a class from the list of direct instance specializers.
(defun remove-direct-instance-specializer (class eql-specializer) ...)
;; Returns the currently existing direct instance specializers, as a freshly
;; consed list.
(defun list-direct-instance-specializers (class) ...)
|#
(def-weak-set-accessors class-direct-instance-specializers-table eql-specializer
  add-direct-instance-specializer
  remove-direct-instance-specializer
  list-direct-instance-specializers)

;;; Maintaining the weak references to the finalized direct subclasses.
;;; (We need only the finalized subclasses, because:
;;;  - The only use of these references is for make-instances-obsolete and for
;;;    update-subclasses-for-redefined-class.
;;;  - A non-finalized class cannot have instances.
;;;  - Without an instance one cannot even access the shared slots.)

;;; The finalized-direct-subclasses slot can be either
;;; - NIL or a weak-list (for saving memory when there are few subclasses), or
;;; - a weak-hash-table (for speed when there are many subclasses).

#|
;; Adds a class to the list of direct subclasses.
(defun add-finalized-direct-subclass (class subclass) ...)
;; Removes a class from the list of direct subclasses.
(defun remove-finalized-direct-subclass (class subclass) ...)
;; Returns the currently existing direct subclasses, as a freshly consed list.
(defun list-finalized-direct-subclasses (class) ...)
|#
(def-weak-set-accessors class-finalized-direct-subclasses-table class
  add-finalized-direct-subclass
  remove-finalized-direct-subclass
  list-finalized-direct-subclasses)

;; Returns the currently existing finalized subclasses, in top-down order,
;; including the class itself as first element.
(defun list-all-finalized-subclasses (class)
  ; Use a breadth-first search which removes duplicates.
  (let ((as-list '())
        (as-set (make-hash-table :key-type 'defined-class :value-type '(eql t)
                                 :test 'ext:stablehash-eq :warn-if-needs-rehash-after-gc t
                                 :rehash-size 2s0))
        (pending (list class)))
    (loop
      (unless pending (return))
      (let ((new-pending '()))
        (dolist (class pending)
          (unless (gethash class as-set)
            (push class as-list)
            (setf (gethash class as-set) t)
            (setq new-pending
              (nreconc (if (semi-standard-class-p class)
                         ; <semi-standard-class> stores the finalized direct-subclasses.
                         (list-finalized-direct-subclasses class)
                         ; <defined-class> stores only the complete direct-subclasses list.
                         (remove-if-not #'(lambda (c) (= (class-initialized c) 6))
                                        (checked-class-direct-subclasses class)))
                       new-pending))))
        (setq pending (nreverse new-pending))))
    ;; Now reorder the list so that superclasses come before, not after, a
    ;; class. This is needed by update-subclasses-for-redefined-class. (It's
    ;; a "topological sorting" algorithm w.r.t. to the superclass relation.)
    (let ((tsorted-list '()))
      (labels ((add-with-superclasses-first (cls)
                 (when (gethash cls as-set)
                   (remhash cls as-set)
                   (dolist (supercls (class-direct-superclasses cls))
                     (add-with-superclasses-first supercls))
                   (push cls tsorted-list))))
        (mapc #'add-with-superclasses-first as-list))
      (setq tsorted-list (nreverse tsorted-list))
      (assert (eq (first tsorted-list) class))
      tsorted-list)))

;; --------------- Creation of an instance of <standard-class> ---------------

(defun make-instance-<standard-class> (metaclass &rest args
                                       &key name
                                            (direct-superclasses '())
                                            (direct-slots '())
                                            (direct-default-initargs '())
                                       &allow-other-keys)
  ;; metaclass = <standard-class>
  ;; Don't add functionality here! This is a preliminary definition that is
  ;; replaced with #'make-instance later.
  (declare (ignore metaclass name direct-superclasses direct-slots
                   direct-default-initargs))
  (let ((class (allocate-metaobject-instance *<standard-class>-class-version*
                                             *<standard-class>-instance-size*)))
    (apply #'initialize-instance-<standard-class> class args)))

(defun initialize-instance-<standard-class> (class &rest args
                                             &key &allow-other-keys)
  ;; Don't add functionality here! This is a preliminary definition that is
  ;; replaced with #'initialize-instance later.
  (apply #'shared-initialize-<standard-class> class 't args)
  (install-class-direct-accessors class)
  class)

(defun shared-initialize-<standard-class> (class situation &rest args
                                           &key (direct-superclasses '() direct-superclasses-p)
                                                ((:direct-slots direct-slots-as-lists) '() direct-slots-as-lists-p)
                                                ((direct-slots direct-slots-as-metaobjects) '() direct-slots-as-metaobjects-p)
                                                (direct-default-initargs '() direct-default-initargs-p)
                                                (documentation nil documentation-p)
                                                (generic-accessors t generic-accessors-p)
                                                (fixed-slot-locations nil fixed-slot-locations-p)
                                           &allow-other-keys)
  (declare (ignore direct-superclasses direct-superclasses-p
                   direct-slots-as-lists direct-slots-as-lists-p
                   direct-slots-as-metaobjects direct-slots-as-metaobjects-p
                   direct-default-initargs direct-default-initargs-p
                   documentation documentation-p generic-accessors
                   generic-accessors-p fixed-slot-locations
                   fixed-slot-locations-p))
  (apply #'shared-initialize-<semi-standard-class> class situation args)
  class)

;; ---------------------------------------------------------------------------

;; Bootstrapping
(progn
  (setq <function> nil)

  ;; 1. Define the class <t>.
  (setq <t>
        (make-instance-<built-in-class> nil
          :name 't
          :direct-superclasses '()
          'prototype (byte 1 0)))
  (setf (find-class 't) <t>)

  ;; 2. Define the class <standard-object>.
  (setq <standard-object>
        (let ((*allow-mixing-metaclasses* t))
          (make-instance-<standard-class> nil
            :name 'standard-object
            :direct-superclasses `(,<t>)
            :direct-slots '()
            :slots '()
            :slot-location-table empty-ht
            :instance-size 1
            :direct-default-initargs '()
            :default-initargs '())))
  (setf (find-class 'standard-object) <standard-object>)

  ;; 3. Define the class <metaobject>.
  (setq <metaobject>
        (macrolet ((form () *<metaobject>-defclass*))
          (form)))

  ;; 4. Define the class <standard-stablehash>.
  (macrolet ((form () *<standard-stablehash>-defclass*))
    (form))

  ;; 5. Define the class <specializer>.
  (macrolet ((form () *<specializer>-defclass*))
    (form))

  ;; 6. Define the classes <super-class>, <potential-class>.
  (macrolet ((form () *<super-class>-defclass*))
    (form))
  (setq <potential-class>
        (macrolet ((form () *<potential-class>-defclass*))
          (form)))

  ;; 7. Define the class <defined-class>.
  (setq <defined-class>
        (macrolet ((form () *<defined-class>-defclass*))
          (form)))

  ;; 8. Define the class <built-in-class>.
  (setq <built-in-class>
        (macrolet ((form () *<built-in-class>-defclass*))
          (form)))
  (replace-class-version <built-in-class>
                         *<built-in-class>-class-version*)

  ;; 9. Define the classes <slotted-class>, <semi-standard-class>,
  ;; <standard-class>, <structure-class>.
  (macrolet ((form () *<slotted-class>-defclass*))
    (form))
  (setq <semi-standard-class>
    (macrolet ((form () *<semi-standard-class>-defclass*))
      (form)))
  (setq <standard-class>
    (macrolet ((form () *<standard-class>-defclass*))
      (form)))
  (replace-class-version <standard-class>
                         *<standard-class>-class-version*)
  (setq <structure-class>
    (macrolet ((form () *<structure-class>-defclass*))
      (form)))
  (replace-class-version <structure-class>
                         *<structure-class>-class-version*)

  ;; 10. Define the class <structure-object>.
  (setq <structure-object>
        (let ((*allow-mixing-metaclasses* t))
          (make-instance-<structure-class> <structure-class>
            :name 'structure-object
            :direct-superclasses `(,<t>)
            :direct-slots '()
            :direct-default-initargs '()
            'names (list 'structure-object))))
  (setf (find-class 'structure-object) <structure-object>)

  ;; 11. Define other classes whose definition was delayed.

  ;; Define the class <slot-definition>.
  (macrolet ((form () *<slot-definition>-defclass*))
    (form))

  ;; Define the class <direct-slot-definition>.
  (setq <direct-slot-definition>
        (macrolet ((form () *<direct-slot-definition>-defclass*))
          (form)))

  ;; Define the class <effective-slot-definition>.
  (setq <effective-slot-definition>
        (macrolet ((form () *<effective-slot-definition>-defclass*))
          (form)))

  ;; Define the class <standard-slot-definition>.
  (macrolet ((form () *<standard-slot-definition>-defclass*))
    (form))

  ;; Define the class <standard-direct-slot-definition>.
  (setq <standard-direct-slot-definition>
        (macrolet ((form () *<standard-direct-slot-definition>-defclass*))
          (form)))
  (replace-class-version (find-class 'standard-direct-slot-definition)
                         *<standard-direct-slot-definition>-class-version*)

  ;; Define the class <standard-effective-slot-definition>.
  (setq <standard-effective-slot-definition>
        (macrolet ((form () *<standard-effective-slot-definition>-defclass*))
          (form)))
  (replace-class-version (find-class 'standard-effective-slot-definition)
                         *<standard-effective-slot-definition>-class-version*)

  ;; Define the class <structure-direct-slot-definition>.
  (setq <structure-direct-slot-definition>
        (macrolet ((form () *<structure-direct-slot-definition>-defclass*))
          (form)))
  (replace-class-version (find-class 'structure-direct-slot-definition)
                         *<structure-direct-slot-definition>-class-version*)

  ;; Define the class <structure-effective-slot-definition>.
  (setq <structure-effective-slot-definition>
        (macrolet ((form () *<structure-effective-slot-definition>-defclass*))
          (form)))
  (replace-class-version (find-class 'structure-effective-slot-definition)
                         *<structure-effective-slot-definition>-class-version*)

  ;; Define the class <eql-specializer>.
  (setq <eql-specializer>
        (macrolet ((form () *<eql-specializer>-defclass*))
          (form)))
  (replace-class-version (find-class 'eql-specializer)
                         *<eql-specializer>-class-version*)

  ;; Define the classes <forward-reference-to-class>,
  ;; <misdesigned-forward-referenced-class>.
  (setq <forward-reference-to-class>
        (macrolet ((form () *<forward-reference-to-class>-defclass*))
                     (form)))
  (setq <misdesigned-forward-referenced-class>
        (macrolet ((form () *<misdesigned-forward-referenced-class>-defclass*))
                     (form)))

);progn

;;; Install built-in classes:
;; See CLtL2 p. 783 table 28-1, ANSI CL 4.3.7.
(macrolet ((def (&rest classes)
             (setq classes (reverse classes))
             (let* ((prototype-form (pop classes))
                    (new (pop classes))
                    (name (intern (string-trim "<>" (symbol-name new)))))
               `(setf (find-class ',name)
                  (setq ,new
                    (make-instance-<built-in-class> <built-in-class>
                      :name ',name
                      :direct-superclasses (list ,@classes)
                      ,@(unless (eq prototype-form '-+-ABSTRACT-+-)
                          `('prototype ,prototype-form))))))))
 ;(def <t>                                           (byte 1 0))
  (def <t> <character>                               #\Space)
  (def <t> <function>                                #'cons)
  (def <t> <hash-table>                              empty-ht)
  (def <t> <package>                                 (find-package "KEYWORD"))
  (def <t> <pathname>                                (make-pathname))
  #+LOGICAL-PATHNAMES
  (def     <pathname> <logical-pathname>             (logical-pathname ":"))
  (def <t> <random-state>                            *random-state*)
  (def <t> <readtable>                               *readtable*)
  (def <t> <stream>                                  -+-ABSTRACT-+-)
  (def     <stream> <file-stream>                    (open *load-pathname* :direction :probe))
  (def     <stream> <synonym-stream>                 (make-synonym-stream '*terminal-io*))
  (def     <stream> <broadcast-stream>               (make-broadcast-stream))
  (def     <stream> <concatenated-stream>            (make-concatenated-stream))
  (def     <stream> <two-way-stream>                 (make-two-way-stream (make-concatenated-stream) (make-broadcast-stream)))
  (def     <stream> <echo-stream>                    (make-echo-stream (make-concatenated-stream) (make-broadcast-stream)))
  (def     <stream> <string-stream>                  (make-string-output-stream))
  (def <t> <symbol>                                  't)
  (def <t> <sequence>                                -+-ABSTRACT-+-)
  (def     <sequence> <list>                         -+-ABSTRACT-+-)
  (def                <list> <cons>                  '(t))
  (def                <list> <symbol> <null>         'nil)
  (def <t>            <array>                        '#2A())
  (def     <sequence> <array> <vector>               '#())
  (def                        <vector> <bit-vector>  '#*)
  (def                        <vector> <string>      "")
  (def <t> <number>                                  -+-ABSTRACT-+-)
  (def     <number> <complex>                        #c(3 4))
  (def     <number> <real>                           -+-ABSTRACT-+-)
  (def              <real> <float>                   1.0s0)
  (def              <real> <rational>                -+-ABSTRACT-+-)
  (def                     <rational> <ratio>        1/2)
  (def                     <rational> <integer>      0)
)

;; Continue bootstrapping.
(%defclos
  ;; distinctive marks for CLASS-P
  *<standard-class>-class-version*
  *<structure-class>-class-version*
  *<built-in-class>-class-version*
  <defined-class>
  <potential-class>
  ;; built-in-classes for CLASS-OF
  (vector <array> <bit-vector> <character> <complex> <cons> <float> <function>
          <hash-table> <integer> <list> <null> <package> <pathname>
          #+LOGICAL-PATHNAMES <logical-pathname>
          <random-state> <ratio> <readtable>
          <stream> <file-stream> <synonym-stream> <broadcast-stream>
          <concatenated-stream> <two-way-stream> <echo-stream> <string-stream>
          <string> <symbol> <t> <vector>))

;;; Intersection of two built-in-classes:
;; Deviations from the single-inheritance are only
;; (AND <sequence> <array>) = <vector> and (AND <list> <symbol>) = <null>.
(defun bc-p (class)
  (or (built-in-class-p class)
      (eq class <standard-object>)
      (eq class <structure-object>)))
(defun bc-and (class1 class2) ; returns (AND class1 class2)
  (cond ((subclassp class1 class2) class1)
        ((subclassp class2 class1) class2)
        ((or (and (subclassp <sequence> class1) (subclassp <array> class2))
             (and (subclassp <sequence> class2) (subclassp <array> class1)))
         <vector>)
        ((or (and (subclassp <list> class1) (subclassp <symbol> class2))
             (and (subclassp <list> class2) (subclassp <symbol> class1)))
         <null>)
        (t nil)))
(defun bc-and-not (class1 class2) ; returns a class c with
                                  ; (AND class1 (NOT class2)) <= c <= class1
  (cond ((subclassp class1 class2) nil)
        ((and (eq class1 <sequence>) (subclassp <vector> class2)) <list>)
        ((and (eq class1 <sequence>) (subclassp <list> class2)) <vector>)
        ((and (eq class1 <list>) (subclassp <null> class2)) <cons>)
        (t class1)))