(dolist (definition *early-class-definitions*)
(let ((name (ecd-class-name definition))
(meta (ecd-metaclass definition))
- (source (ecd-source definition))
+ (source (ecd-source-location definition))
(direct-supers (ecd-superclass-names definition))
(direct-slots (ecd-canonical-slots definition))
(other-initargs (ecd-other-initargs definition)))
smc
name
value)))
- (set-slot 'source *load-pathname*)
- (set-slot 'type 'standard)
- (set-slot 'documentation "The standard method combination.")
+ (set-slot 'source nil)
+ (set-slot 'type-name 'standard)
+ (set-slot '%documentation "The standard method combination.")
(set-slot 'options ()))
(setq *standard-method-combination* smc))))
(set-slot 'name name)
(set-slot 'finalized-p t)
(set-slot 'source source)
- (set-slot 'type (if (eq class (find-class t))
- t
- ;; FIXME: Could this just be CLASS instead
- ;; of `(CLASS ,CLASS)? If not, why not?
- ;; (See also similar expression in
- ;; SHARED-INITIALIZE :BEFORE (CLASS).)
- `(class ,class)))
+ (set-slot '%type (if (eq class (find-class t))
+ t
+ ;; FIXME: Could this just be CLASS instead
+ ;; of `(CLASS ,CLASS)? If not, why not?
+ ;; (See also similar expression in
+ ;; SHARED-INITIALIZE :BEFORE (CLASS).)
+ `(class ,class)))
(set-slot 'class-eq-specializer
(let ((spec (allocate-standard-instance class-eq-wrapper)))
- (!bootstrap-set-slot 'class-eq-specializer spec 'type
+ (!bootstrap-set-slot 'class-eq-specializer spec '%type
`(class-eq ,class))
(!bootstrap-set-slot 'class-eq-specializer spec 'object
class)
spec))
- (set-slot 'class-precedence-list (classes cpl))
+ (set-slot '%class-precedence-list (classes cpl))
(set-slot 'cpl-available-p t)
(set-slot 'can-precede-list (classes (cdr cpl)))
(set-slot 'incompatible-superclass-list nil)
(set-slot 'direct-subclasses (classes direct-subclasses))
(set-slot 'direct-methods (cons nil nil))
(set-slot 'wrapper wrapper)
- (set-slot 'predicate-name (or (cadr (assoc name *early-class-predicates*))
- (make-class-predicate-name name)))
- (set-slot 'documentation nil)
+ (set-slot '%documentation nil)
(set-slot 'plist
`(,@(and direct-default-initargs
`(direct-default-initargs ,direct-default-initargs))
(case metaclass-name
(structure-class
(let ((constructor-sym '|STRUCTURE-OBJECT class constructor|))
- (set-slot 'predicate-name (or (cadr (assoc name
- *early-class-predicates*))
- (make-class-predicate-name name)))
(set-slot 'defstruct-form
`(defstruct (structure-object (:constructor
,constructor-sym)
(set-val 'readers (get-val :readers))
(set-val 'writers (get-val :writers))
(set-val 'allocation :instance)
- (set-val 'type (or (get-val :type) t))
- (set-val 'documentation (or (get-val :documentation) ""))
- (set-val 'class class)
+ (set-val '%type (or (get-val :type) t))
+ (set-val '%documentation (or (get-val :documentation) ""))
+ (set-val '%class class)
(when effective-p
(set-val 'location index)
(let ((fsc-p nil))
fsc-p nil slot-name index))
(set-val 'boundp-function (make-optimized-std-boundp-method-function
fsc-p nil slot-name index)))
- (set-val 'accessor-flags 7)
- (let ((table (or (gethash slot-name *name->class->slotd-table*)
- (setf (gethash slot-name *name->class->slotd-table*)
- (make-hash-table :test 'eq :size 5)))))
- (setf (gethash class table) slotd)))
+ (set-val 'accessor-flags 7))
(when (and (eq name 'standard-class)
(eq slot-name 'slots) effective-p)
(setq *the-eslotd-standard-class-slots* slotd))
slot-name
readers
writers
- nil)
- (!bootstrap-accessor-definitions1
- 'slot-object
- slot-name
- (list (slot-reader-name slot-name))
- (list (slot-writer-name slot-name))
- (list (slot-boundp-name slot-name)))))))))))
+ nil)))))))))
(defun !bootstrap-accessor-definition (class-name accessor-name slot-name type)
(multiple-value-bind (accessor-class make-method-function arglist specls doc)
(dolist (writer writers) (do-writer-definition writer))
(dolist (boundp boundps) (do-boundp-definition boundp))))
+;;; FIXME: find a better name.
(defun !bootstrap-class-predicates (early-p)
(let ((*early-p* early-p))
- (dolist (definition *early-class-definitions*)
- (let* ((name (ecd-class-name definition))
- (class (find-class name)))
- (setf (find-class-predicate name)
- (make-class-predicate class (class-predicate-name class)))))))
+ (dolist (ecp *early-class-predicates*)
+ (let ((class-name (car ecp))
+ (predicate-name (cadr ecp)))
+ (make-class-predicate (find-class class-name) predicate-name)))))
(defun !bootstrap-built-in-classes ()
name class-eq-wrapper nil
supers subs
(cons name cpl)
- wrapper prototype)))))
-
- (dolist (e *built-in-classes*)
- (let* ((name (car e))
- (class (find-class name)))
- (setf (find-class-predicate name)
- (make-class-predicate class (class-predicate-name class))))))
+ wrapper prototype))))))
\f
(defmacro wrapper-of-macro (x)
`(layout-of ,x))
(t
(error "~@<~S is not the name of a class.~@:>" name)))))
-(defun ensure-defstruct-class (classoid)
+(defun ensure-deffoo-class (classoid)
(let ((class (classoid-pcl-class classoid)))
(cond (class
(ensure-non-standard-class (class-name class) class))
((eq 'complete *boot-state*)
(ensure-non-standard-class (classoid-name classoid))))))
-(pushnew 'ensure-defstruct-class sb-kernel::*defstruct-hooks*)
+(pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*)
+(pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*)
\f
(defun make-class-predicate (class name)
(let* ((gf (ensure-generic-function name :lambda-list '(object)))
projects / sbcl.git / blobdiff