(apply #'make-instance (find-class class) initargs))
(defmethod make-instance ((class class) &rest initargs)
+ (let ((instance-or-nil (maybe-call-ctor class initargs)))
+ (when instance-or-nil
+ (return-from make-instance instance-or-nil)))
(unless (class-finalized-p class) (finalize-inheritance class))
(let ((class-default-initargs (class-default-initargs class)))
(when class-default-initargs
- (setf initargs (default-initargs class initargs class-default-initargs)))
+ (setf initargs (default-initargs initargs class-default-initargs)))
(when initargs
- (when (and (eq *boot-state* 'complete)
- (not (getf initargs :allow-other-keys)))
- (let ((class-proto (class-prototype class)))
- (check-initargs-1
- class initargs
- (append (compute-applicable-methods
- #'allocate-instance (list class))
- (compute-applicable-methods
- #'initialize-instance (list class-proto))
- (compute-applicable-methods
- #'shared-initialize (list class-proto t)))))))
+ (when (eq **boot-state** 'complete)
+ (check-mi-initargs class initargs)))
(let ((instance (apply #'allocate-instance class initargs)))
(apply #'initialize-instance instance initargs)
instance)))
-(defmethod default-initargs ((class slot-class)
- supplied-initargs
- class-default-initargs)
+(defun default-initargs (supplied-initargs class-default-initargs)
(loop for (key nil fun) in class-default-initargs
when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
append (list key (funcall fun)) into default-initargs
(flet ((initialize-slot-from-initarg (class instance slotd)
(let ((slot-initargs (slot-definition-initargs slotd)))
(doplist (initarg value) initargs
- (when (memq initarg slot-initargs)
- (setf (slot-value-using-class class instance slotd)
- value)
- (return t)))))
+ (when (memq initarg slot-initargs)
+ (setf (slot-value-using-class class instance slotd)
+ value)
+ (return t)))))
(initialize-slot-from-initfunction (class instance slotd)
;; CLHS: If a before method stores something in a slot,
;; that slot won't be initialized from its :INITFORM, if any.
unless (initialize-slot-from-initarg class instance slotd)
collect slotd)))
(dolist (slotd initfn-slotds)
- (unless (eq (slot-definition-allocation slotd) :class)
- ;; :ALLOCATION :CLASS slots use the :INITFORM when class is defined
- ;; or redefined, not when instances are allocated.
- (when (or (eq t slot-names)
- (memq (slot-definition-name slotd) slot-names))
- (initialize-slot-from-initfunction class instance slotd)))))
+ (when (or (eq t slot-names)
+ (memq (slot-definition-name slotd) slot-names))
+ (initialize-slot-from-initfunction class instance slotd))))
instance))
\f
;;; If initargs are valid return nil, otherwise signal an error.