slot-name
readers
writers
- nil)))))))))
+ nil
+ (ecd-source-location definition))))))))))
-(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type)
+(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type source-location)
(multiple-value-bind (accessor-class make-method-function arglist specls doc)
(ecase type
(reader (values 'standard-reader-method
doc
:slot-name slot-name
:object-class class-name
- :method-class-function (constantly (find-class accessor-class))))))))
+ :method-class-function (constantly (find-class accessor-class))
+ :definition-source source-location))))))
(defun !bootstrap-accessor-definitions1 (class-name
- slot-name
- readers
- writers
- boundps)
+ slot-name
+ readers
+ writers
+ boundps
+ source-location)
(flet ((do-reader-definition (reader)
(!bootstrap-accessor-definition class-name
reader
slot-name
- 'reader))
+ 'reader
+ source-location))
(do-writer-definition (writer)
(!bootstrap-accessor-definition class-name
writer
slot-name
- 'writer))
+ 'writer
+ source-location))
(do-boundp-definition (boundp)
(!bootstrap-accessor-definition class-name
boundp
slot-name
- 'boundp)))
+ 'boundp
+ source-location)))
(dolist (reader readers) (do-reader-definition reader))
(dolist (writer writers) (do-writer-definition writer))
(dolist (boundp boundps) (do-boundp-definition boundp))))
(defun eval-form (form)
(lambda () (eval form)))
-(defun ensure-non-standard-class (name &optional existing-class)
+(defun ensure-non-standard-class (name classoid &optional existing-class)
(flet
((ensure (metaclass &optional (slots nil slotsp))
- (let ((supers
- (mapcar #'classoid-name (classoid-direct-superclasses
- (find-classoid name)))))
+ (let ((supers (mapcar #'classoid-name (classoid-direct-superclasses classoid))))
(if slotsp
(ensure-class-using-class existing-class name
:metaclass metaclass :name name
((condition-type-p name)
(ensure 'condition-class
(mapcar #'slot-initargs-from-condition-slot
- (condition-classoid-slots (find-classoid name)))))
+ (condition-classoid-slots classoid))))
(t
(error "~@<~S is not the name of a class.~@:>" name)))))
(defun ensure-deffoo-class (classoid)
(let ((class (classoid-pcl-class classoid)))
(cond (class
- (ensure-non-standard-class (class-name class) class))
+ (ensure-non-standard-class (class-name class) classoid class))
((eq 'complete *boot-state*)
- (ensure-non-standard-class (classoid-name classoid))))))
+ (ensure-non-standard-class (classoid-name classoid) classoid)))))
(pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*)
(pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*)
(defun make-class-predicate (class name)
(let* ((gf (ensure-generic-function name :lambda-list '(object)))
(mlist (if (eq *boot-state* 'complete)
- (generic-function-methods gf)
- (early-gf-methods gf))))
+ (early-gf-methods gf)
+ (generic-function-methods gf))))
(unless mlist
(unless (eq class *the-class-t*)
(let* ((default-method-function #'constantly-nil)
(setf (info :type :translator class)
(lambda (spec) (declare (ignore spec)) classoid)))))
-(clrhash *find-class*)
(!bootstrap-meta-braid)
(!bootstrap-accessor-definitions t)
(!bootstrap-class-predicates t)
(!bootstrap-class-predicates nil)
(!bootstrap-built-in-classes)
-(dohash ((name x) *find-class*)
- (let* ((class (find-class-from-cell name x))
- (layout (class-wrapper class))
- (lclass (layout-classoid layout))
- (lclass-pcl-class (classoid-pcl-class lclass))
- (olclass (find-classoid name nil)))
- (if lclass-pcl-class
- (aver (eq class lclass-pcl-class))
- (setf (classoid-pcl-class lclass) class))
-
- (update-lisp-class-layout class layout)
-
- (cond (olclass
- (aver (eq lclass olclass)))
- (t
- (setf (find-classoid name) lclass)))
-
- (set-class-type-translation class name)))
+(dohash ((name x) sb-kernel::*classoid-cells*)
+ (when (classoid-cell-pcl-class x)
+ (let* ((class (find-class-from-cell name x))
+ (layout (class-wrapper class))
+ (lclass (layout-classoid layout))
+ (lclass-pcl-class (classoid-pcl-class lclass))
+ (olclass (find-classoid name nil)))
+ (if lclass-pcl-class
+ (aver (eq class lclass-pcl-class))
+ (setf (classoid-pcl-class lclass) class))
+
+ (update-lisp-class-layout class layout)
+
+ (cond (olclass
+ (aver (eq lclass olclass)))
+ (t
+ (setf (find-classoid name) lclass)))
+
+ (set-class-type-translation class name))))
(setq *boot-state* 'braid)