/src/clos-class3.lisp

Large files files are truncated, but you can click here to view the full file

;;;; 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 introduc…

Large files files are truncated, but you can click here to view the full file