3 ;;; HACK: We are ending up with classes named NIL in the superclass list.
4 ;;; These cannot be given the special object superclass when re-initializing
5 ;;; is it will be in the subclasses superclasses AFTER this class, causing
7 ;;; Since we don't care about these classes (?) this might work (?)
9 (defmethod initialize-instance :around
10 ((class special-class
) &rest initargs
11 &key direct-superclasses
)
12 (declare (dynamic-extent initargs
))
15 (not (ignore-errors (class-name class
)))
17 (loop for superclass in direct-superclasses
18 thereis
(ignore-errors (subtypep superclass
'special-object
))))
20 (progn (apply #'call-next-method class
22 (append direct-superclasses
23 (list (find-class 'special-object
)))
26 (defmethod reinitialize-instance :around
27 ((class special-class
) &rest initargs
28 &key
(direct-superclasses () direct-superclasses-p
))
29 (declare (dynamic-extent initargs
))
30 (if direct-superclasses-p
31 (if (or ; Here comes the hack
32 (not (class-name class
))
34 (loop for superclass in direct-superclasses
35 thereis
(ignore-errors (subtypep superclass
'special-object
))))
37 (apply #'call-next-method class
39 (append direct-superclasses
41 (find-class 'special-object
)))
47 (defun funcall-with-special-initargs (bindings thunk
)
50 (loop for
(object . initargs
) in bindings
51 for initarg-keys
= (loop for key in initargs by
#'cddr
54 finally
(incf arg-count count
)
56 nconc
(loop for slot in
(class-slots (class-of object
))
57 when
(and (slot-definition-specialp slot
)
58 (intersection initarg-keys
(slot-definition-initargs slot
)))
59 collect
(with-symbol-access
60 (slot-value object
(slot-definition-name slot
)))))
61 (make-list arg-count
:initial-element nil
)
62 (loop for
(object . initargs
) in bindings
63 do
(apply #'shared-initialize object nil
:allow-other-keys t initargs
))