(allocate-standard-funcallable-instance-slots
wrapper slots-init-p slots-init))
fin))
+
+(defun classify-slotds (slotds)
+ (let (instance-slots class-slots custom-slots bootp)
+ (dolist (slotd slotds)
+ (let ((alloc (cond ((consp slotd) ; bootstrap
+ (setf bootp t)
+ :instance)
+ (t
+ (slot-definition-allocation slotd)))))
+ (case alloc
+ (:instance
+ (push slotd instance-slots))
+ (:class
+ (push slotd class-slots))
+ (t
+ (push slotd custom-slots)))))
+ (values (if bootp
+ (nreverse instance-slots)
+ (when slotds
+ (sort instance-slots #'< :key #'slot-definition-location)))
+ class-slots
+ custom-slots)))
\f
;;;; BOOTSTRAP-META-BRAID
;;;;
(let ((wr (format-symbol *pcl-package* "~A-WRAPPER" class)))
`(setf ,wr ,(if (eq class 'standard-generic-function)
'*sgf-wrapper*
- `(boot-make-wrapper
+ `(!boot-make-wrapper
(early-class-size ',class)
',class))
,class (allocate-standard-instance
((eq class standard-generic-function)
standard-generic-function-wrapper)
(t
- (boot-make-wrapper (length slots) name))))
+ (!boot-make-wrapper (length slots) name))))
(proto nil))
(when (eq name t) (setq *the-wrapper-of-t* wrapper))
(set (make-class-symbol name) class)
(error "Slot allocation ~S is not supported in bootstrap."
(getf slot :allocation))))
- (when (typep wrapper 'wrapper)
- (setf (wrapper-instance-slots-layout wrapper)
- (mapcar (lambda (slotd)
- ;; T is the slot-definition-type.
- (cons (canonical-slot-name slotd) t))
- slots))
- (setf (wrapper-class-slots wrapper)
- ()))
+ (when (wrapper-p wrapper)
+ (setf (wrapper-slots wrapper) slots))
(setq proto (if (eq meta 'funcallable-standard-class)
(allocate-standard-funcallable-instance wrapper)
standard-effective-slot-definition-wrapper t))
(setf (layout-slot-table wrapper) (make-slot-table class slots t))
+ (when (wrapper-p wrapper)
+ (setf (wrapper-slots wrapper) slots))
(case meta
((standard-class funcallable-standard-class)
(setf (layout-slot-table wrapper)
(make-slot-table class slots
(member metaclass-name
- '(standard-class funcallable-standard-class)))))
+ '(standard-class funcallable-standard-class))))
+ (when (wrapper-p wrapper)
+ (setf (wrapper-slots wrapper) slots)))
;; For all direct superclasses SUPER of CLASS, make sure CLASS is
;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
(set-val 'initform (get-val :initform))
(set-val 'initfunction (get-val :initfunction))
(set-val 'initargs (get-val :initargs))
- (set-val 'readers (get-val :readers))
- (set-val 'writers (get-val :writers))
+ (unless effective-p
+ (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) ""))
:readers ,(condition-slot-readers slot)
:writers ,(condition-slot-writers slot)
,@(when (condition-slot-initform-p slot)
- (let ((form-or-fun (condition-slot-initform slot)))
- (if (functionp form-or-fun)
- `(:initfunction ,form-or-fun)
- `(:initform ,form-or-fun
- :initfunction ,(lambda () form-or-fun)))))
+ (let ((initform (condition-slot-initform slot))
+ (initfun (condition-slot-initfunction slot)))
+ `(:initform ',initform :initfunction ,initfun)))
:allocation ,(condition-slot-allocation slot)
:documentation ,(condition-slot-documentation slot))))
(cond ((structure-type-p name)