- (meta (ecd-metaclass definition))
- (source (ecd-source definition))
- (direct-supers (ecd-superclass-names definition))
- (direct-slots (ecd-canonical-slots definition))
- (other-initargs (ecd-other-initargs definition)))
- (let ((direct-default-initargs
- (getf other-initargs :direct-default-initargs)))
- (multiple-value-bind (slots cpl default-initargs direct-subclasses)
- (early-collect-inheritance name)
- (let* ((class (find-class name))
- (wrapper (cond ((eq class slot-class)
- slot-class-wrapper)
- ((eq class std-class)
- std-class-wrapper)
- ((eq class standard-class)
- standard-class-wrapper)
- ((eq class funcallable-standard-class)
- funcallable-standard-class-wrapper)
- ((eq class standard-direct-slot-definition)
- standard-direct-slot-definition-wrapper)
- ((eq class
- standard-effective-slot-definition)
- standard-effective-slot-definition-wrapper)
- ((eq class built-in-class)
- built-in-class-wrapper)
- ((eq class structure-class)
- structure-class-wrapper)
- ((eq class class-eq-specializer)
- class-eq-specializer-wrapper)
- ((eq class standard-generic-function)
- standard-generic-function-wrapper)
- (t
- (boot-make-wrapper (length slots) name))))
- (proto nil))
- (when (eq name t) (setq *the-wrapper-of-t* wrapper))
- (set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
- *pcl-package*)
- class)
- (dolist (slot slots)
- (unless (eq (getf slot :allocation :instance) :instance)
- (error "Slot allocation ~S is not supported in bootstrap.")))
-
- (when (typep wrapper 'wrapper)
- (setf (wrapper-instance-slots-layout wrapper)
- (mapcar #'canonical-slot-name slots))
- (setf (wrapper-class-slots wrapper)
- ()))
-
- (setq proto (if (eq meta 'funcallable-standard-class)
- (allocate-funcallable-instance wrapper)
- (allocate-standard-instance wrapper)))
-
- (setq direct-slots
- (!bootstrap-make-slot-definitions
- name class direct-slots
- standard-direct-slot-definition-wrapper nil))
- (setq slots
- (!bootstrap-make-slot-definitions
- name class slots
- standard-effective-slot-definition-wrapper t))
-
- (case meta
- ((std-class standard-class funcallable-standard-class)
- (!bootstrap-initialize-class
- meta
- class name class-eq-specializer-wrapper source
- direct-supers direct-subclasses cpl wrapper proto
- direct-slots slots direct-default-initargs default-initargs))
- (built-in-class ; *the-class-t*
- (!bootstrap-initialize-class
- meta
- class name class-eq-specializer-wrapper source
- direct-supers direct-subclasses cpl wrapper proto))
- (slot-class ; *the-class-slot-object*
- (!bootstrap-initialize-class
- meta
- class name class-eq-specializer-wrapper source
- direct-supers direct-subclasses cpl wrapper proto))
- (structure-class ; *the-class-structure-object*
- (!bootstrap-initialize-class
- meta
- class name class-eq-specializer-wrapper source
- direct-supers direct-subclasses cpl wrapper))))))))
+ (meta (ecd-metaclass definition))
+ (source (ecd-source-location definition))
+ (direct-supers (ecd-superclass-names definition))
+ (direct-slots (ecd-canonical-slots definition))
+ (other-initargs (ecd-other-initargs definition)))
+ (let ((direct-default-initargs
+ (getf other-initargs :direct-default-initargs)))
+ (multiple-value-bind (slots cpl default-initargs direct-subclasses)
+ (early-collect-inheritance name)
+ (let* ((class (find-class name))
+ (wrapper (cond ((eq class slot-class)
+ slot-class-wrapper)
+ ((eq class standard-class)
+ standard-class-wrapper)
+ ((eq class funcallable-standard-class)
+ funcallable-standard-class-wrapper)
+ ((eq class standard-direct-slot-definition)
+ standard-direct-slot-definition-wrapper)
+ ((eq class
+ standard-effective-slot-definition)
+ standard-effective-slot-definition-wrapper)
+ ((eq class built-in-class)
+ built-in-class-wrapper)
+ ((eq class structure-class)
+ structure-class-wrapper)
+ ((eq class condition-class)
+ condition-class-wrapper)
+ ((eq class class-eq-specializer)
+ class-eq-specializer-wrapper)
+ ((eq class standard-generic-function)
+ standard-generic-function-wrapper)
+ (t
+ (boot-make-wrapper (length slots) name))))
+ (proto nil))
+ (when (eq name t) (setq *the-wrapper-of-t* wrapper))
+ (set (make-class-symbol name) class)
+ (dolist (slot slots)
+ (unless (eq (getf slot :allocation :instance) :instance)
+ (error "Slot allocation ~S is not supported in bootstrap."
+ (getf slot :allocation))))
+
+ (when (typep wrapper 'wrapper)
+ (setf (wrapper-instance-slots-layout wrapper)
+ (mapcar #'canonical-slot-name slots))
+ (setf (wrapper-class-slots wrapper)
+ ()))
+
+ (setq proto (if (eq meta 'funcallable-standard-class)
+ (allocate-standard-funcallable-instance wrapper)
+ (allocate-standard-instance wrapper)))
+
+ (setq direct-slots
+ (!bootstrap-make-slot-definitions
+ name class direct-slots
+ standard-direct-slot-definition-wrapper nil))
+ (setq slots
+ (!bootstrap-make-slot-definitions
+ name class slots
+ standard-effective-slot-definition-wrapper t))
+
+ (setf (layout-slot-table wrapper) (make-slot-table class slots t))
+
+ (case meta
+ ((standard-class funcallable-standard-class)
+ (!bootstrap-initialize-class
+ meta
+ class name class-eq-specializer-wrapper source
+ direct-supers direct-subclasses cpl wrapper proto
+ direct-slots slots direct-default-initargs default-initargs))
+ (built-in-class ; *the-class-t*
+ (!bootstrap-initialize-class
+ meta
+ class name class-eq-specializer-wrapper source
+ direct-supers direct-subclasses cpl wrapper proto))
+ (slot-class ; *the-class-slot-object*
+ (!bootstrap-initialize-class
+ meta
+ class name class-eq-specializer-wrapper source
+ direct-supers direct-subclasses cpl wrapper proto))
+ (structure-class ; *the-class-structure-object*
+ (!bootstrap-initialize-class
+ meta
+ class name class-eq-specializer-wrapper source
+ direct-supers direct-subclasses cpl wrapper))
+ (condition-class
+ (!bootstrap-initialize-class
+ meta
+ class name class-eq-specializer-wrapper source
+ direct-supers direct-subclasses cpl wrapper))))))))
+
+ (setq **standard-method-classes**
+ (mapcar (lambda (name)
+ (symbol-value (make-class-symbol name)))
+ *standard-method-class-names*))