7 ;;; Since i'm not using deflayer, ensure-layer etc,
8 ;;; There are a few places where contextl gets confused
9 ;;; trying to locate my description layers.
11 ;;; TODO: investigate switching to deflayer!
13 (defun contextl::prepare-layer
(layer)
15 (if (eq (symbol-package layer
)
16 (find-package :description-definers
))
18 (contextl::defining-layer layer
))
22 (defmethod find-layer-class :around
((layer symbol
) &optional errorp environment
)
23 (if (eq (symbol-package layer
)
24 (find-package :description-definers
))
29 ;;; HACK: We are ending up with classes named NIL in the superclass list.
30 ;;; These cannot be given the special object superclass when re-initializing
31 ;;; is it will be in the subclasses superclasses AFTER this class, causing
33 ;;; Since we don't care about these classes (?) this might work (?)
35 (defmethod initialize-instance :around
36 ((class special-class
) &rest initargs
37 &key direct-superclasses
)
38 (declare (dynamic-extent initargs
))
41 (not (ignore-errors (class-name class
)))
43 (loop for superclass in direct-superclasses
44 thereis
(ignore-errors (subtypep superclass
'special-object
))))
46 (progn (apply #'call-next-method class
48 (append direct-superclasses
49 (list (find-class 'special-object
)))
52 (defmethod reinitialize-instance :around
53 ((class special-class
) &rest initargs
54 &key
(direct-superclasses () direct-superclasses-p
))
55 (declare (dynamic-extent initargs
))
56 (if direct-superclasses-p
57 (if (or ; Here comes the hack
58 (not (class-name class
))
60 (loop for superclass in direct-superclasses
61 thereis
(ignore-errors (subtypep superclass
'special-object
))))
63 (apply #'call-next-method class
65 (append direct-superclasses
67 (find-class 'special-object
)))
73 (defun funcall-with-special-initargs (bindings thunk
)
76 (loop for
(object . initargs
) in bindings
77 for initarg-keys
= (loop for key in initargs by
#'cddr
80 finally
(incf arg-count count
)
82 nconc
(loop for slot in
(class-slots (class-of object
))
83 when
(and (slot-definition-specialp slot
)
84 (intersection initarg-keys
(slot-definition-initargs slot
)))
85 collect
(with-symbol-access
86 (slot-value object
(slot-definition-name slot
)))))
87 (make-list arg-count
:initial-element nil
)
88 (loop for
(object . initargs
) in bindings
89 do
(apply #'shared-initialize object nil
:allow-other-keys t initargs
))