(defmethod default-initargs ((class slot-class)
supplied-initargs
class-default-initargs)
- (loop for (key fn) in 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 fn)) into default-initargs
+ append (list key (funcall fun)) into default-initargs
finally
(return (append supplied-initargs default-initargs))))
(let ((initfn (slot-definition-initfunction slotd)))
(when initfn
(funcall initfn)))))
- (unless (or (slot-boundp-using-class class instance slotd)
- (null (slot-definition-initfunction slotd)))
+ (unless (or (null (slot-definition-initfunction slotd))
+ (slot-boundp-using-class class instance slotd))
(setf (slot-value-using-class class instance slotd)
(funcall (slot-definition-initfunction slotd)))))))
(let* ((class (class-of instance))
(loop for slotd in (class-slots class)
unless (initialize-slot-from-initarg class instance slotd)
collect slotd)))
- (loop for slotd in initfn-slotds
- when (and (not (eq :class (slot-definition-allocation slotd)))
- (or (eq t slot-names)
- (memq (slot-definition-name slotd) slot-names))) do
- (initialize-slot-from-initfunction class instance slotd)))
+ (dolist (slotd initfn-slotds)
+ (if (eq (slot-definition-allocation slotd) :class)
+ (when (or (eq t slot-names)
+ (memq (slot-definition-name slotd) slot-names))
+ (unless (slot-boundp-using-class class instance slotd)
+ (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.
(setq legal (append keys legal))))
(values legal nil)))
-(define-condition initarg-error (program-error)
+(define-condition initarg-error (reference-condition program-error)
((class :reader initarg-error-class :initarg :class)
(initargs :reader initarg-error-initargs :initarg :initargs))
+ (:default-initargs :references (list '(:ansi-cl :section (7 1 2))))
(:report (lambda (condition stream)
- (format stream "~@<Invalid initialization argument~P:~2I~_~
- ~<~{~S~^, ~}~@:>~I~_in call for class ~S.~:>"
+ (format stream "~@<Invalid initialization argument~P: ~2I~_~
+ ~<~{~S~^, ~} ~@:>~I~_in call for class ~S.~:>"
(length (initarg-error-initargs condition))
(list (initarg-error-initargs condition))
(initarg-error-class condition)))))
;; Now check the supplied-initarg-names and the default initargs
;; against the total set that we know are legal.
(doplist (key val) initargs
- (unless (memq key legal)
+ (unless (or (memq key legal)
+ ;; :ALLOW-OTHER-KEYS NIL gets here
+ (eq key :allow-other-keys))
(push key invalid-keys)))
(when (and invalid-keys error-p)
(error 'initarg-error :class class :initargs invalid-keys)))