- (if (and (not (structure-class-p class))
- (not (condition-class-p class))
- (null (cdr make-instance-methods))
- (null (cdr allocate-instance-methods))
- (every (lambda (x)
- (member (slot-definition-allocation x)
- '(:instance :class)))
- (class-slots class))
- (null (check-initargs-1
- class
- (append
- (ctor-default-initkeys
- (ctor-initargs ctor) (class-default-initargs class))
- (plist-keys (ctor-initargs ctor)))
- (append ii-methods si-methods) nil nil))
- (not (around-or-nonstandard-primary-method-p
- ii-methods *the-system-ii-method*))
- (not (around-or-nonstandard-primary-method-p
- si-methods *the-system-si-method*))
- ;; the instance structure protocol goes through
- ;; slot-value(-using-class) and friends (actually just
- ;; (SETF SLOT-VALUE-USING-CLASS) and
- ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard
- ;; applicable methods we can't shortcircuit them.
- (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods)
- (every (lambda (x) (= (length x) 1)) sbuc-slots-methods))
- (optimizing-generator ctor ii-methods si-methods)
- (fallback-generator ctor ii-methods si-methods))))
+ (let ((maybe-invalid-initargs
+ (check-initargs-1
+ class
+ (append
+ (ctor-default-initkeys
+ (ctor-initargs ctor) (class-default-initargs class))
+ (plist-keys (ctor-initargs ctor)))
+ (append ii-methods si-methods) nil nil))
+ (custom-make-instance
+ (not (null (cdr make-instance-methods)))))
+ (if (and (not (structure-class-p class))
+ (not (condition-class-p class))
+ (not custom-make-instance)
+ (null (cdr allocate-instance-methods))
+ (every (lambda (x)
+ (member (slot-definition-allocation x)
+ '(:instance :class)))
+ (class-slots class))
+ (not maybe-invalid-initargs)
+ (not (around-or-nonstandard-primary-method-p
+ ii-methods *the-system-ii-method*))
+ (not (around-or-nonstandard-primary-method-p
+ si-methods *the-system-si-method*))
+ ;; the instance structure protocol goes through
+ ;; slot-value(-using-class) and friends (actually just
+ ;; (SETF SLOT-VALUE-USING-CLASS) and
+ ;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard
+ ;; applicable methods we can't shortcircuit them.
+ (every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods)
+ (every (lambda (x) (= (length x) 1)) sbuc-slots-methods))
+ (optimizing-generator ctor ii-methods si-methods)
+ (fallback-generator ctor ii-methods si-methods
+ (or maybe-invalid-initargs custom-make-instance))))))