;;; Utilities *******
;;; ******************
+(defun quote-plist-keys (plist)
+ (loop for (key . more) on plist by #'cddr
+ if (null more) do
+ (error "Not a property list: ~S" plist)
+ else
+ collect `(quote ,key)
+ and collect (car more)))
+
(defun plist-keys (plist &key test)
(loop for (key . more) on plist by #'cddr
if (null more) do
(and (symbolp constant)
(not (null (symbol-package constant)))))))
+;;; somewhat akin to DEFAULT-INITARGS (SLOT-CLASS T T), but just
+;;; collecting the defaulted initargs for the call.
+(defun ctor-default-initkeys (supplied-initargs class-default-initargs)
+ (loop for (key nil) in class-default-initargs
+ when (eq (getf supplied-initargs key '.not-there.) '.not-there.)
+ collect key))
\f
;;; *****************
;;; CTORS *********
(member (slot-definition-allocation x)
'(:instance :class)))
(class-slots class))
- (null (check-initargs-1 class (plist-keys (ctor-initargs ctor))
- (append ii-methods si-methods) nil nil))
+ (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
(slot-inits (slot-init-forms ctor (or ii-before si-before))))
(values
`(let (,@(when (or ii-before ii-after)
- `((.ii-args. (list .instance. ,@initargs))))
+ `((.ii-args.
+ (list .instance. ,@(quote-plist-keys initargs)))))
,@(when (or si-before si-after)
- `((.si-args. (list .instance. t ,@initargs)))))
+ `((.si-args.
+ (list .instance. t ,@(quote-plist-keys initargs))))))
,@(loop for method in ii-before
collect `(invoke-method ,method .ii-args.))
,@(loop for method in si-before