4 (defmethod contextl:layer-name
:around
(layer)
5 (or (call-next-method) layer
))
8 ;;; Since i'm not using deflayer, ensure-layer etc,
9 ;;; There are a few places where contextl gets confused
10 ;;; trying to locate my description layers.
12 ;;; TODO: investigate switching to deflayer!
14 (defun contextl::prepare-layer
(layer)
16 (if (eq (symbol-package layer
)
17 (find-package :description-definers
))
19 (contextl::defining-layer layer
))
23 (defmethod find-layer-class :around
((layer symbol
) &optional errorp environment
)
24 (if (eq (symbol-package layer
)
25 (find-package :description-definers
))
30 ;;; HACK: There are classes named NIL (partial classes) in the superclass list.
31 ;;; These cannot be given the special object superclass when re-initializing
32 ;;; is it will be in the subclasses superclasses AFTER this class, causing
34 ;;; Since we don't care about these classes (?) this might work (?)
36 (defmethod initialize-instance :around
37 ((class special-class
) &rest initargs
38 &key direct-superclasses
)
39 (declare (dynamic-extent initargs
))
42 (not (ignore-errors (class-name class
)))
44 (loop for superclass in direct-superclasses
45 thereis
(ignore-errors (subtypep superclass
'special-object
))))
47 (progn (apply #'call-next-method class
49 (append direct-superclasses
50 (list (find-class 'special-object
)))
53 (defmethod reinitialize-instance :around
54 ((class special-class
) &rest initargs
55 &key
(direct-superclasses () direct-superclasses-p
))
56 (declare (dynamic-extent initargs
))
57 (if direct-superclasses-p
58 (if (or ; Here comes the hack
59 (not (class-name class
))
61 (loop for superclass in direct-superclasses
62 thereis
(ignore-errors (subtypep superclass
'special-object
))))
64 (apply #'call-next-method class
66 (append direct-superclasses
68 (find-class 'special-object
)))
74 (defun funcall-with-special-initargs (bindings thunk
)
77 (loop for
(object . initargs
) in bindings
78 for initarg-keys
= (loop for key in initargs by
#'cddr
81 finally
(incf arg-count count
)
83 nconc
(loop for slot in
(class-slots (class-of object
))
84 when
(and (slot-definition-specialp slot
)
85 (intersection initarg-keys
(slot-definition-initargs slot
)))
86 collect
(with-symbol-access
87 (slot-value object
(slot-definition-name slot
)))))
88 (make-list arg-count
:initial-element nil
)
89 (loop for
(object . initargs
) in bindings
90 do
(apply #'shared-initialize object nil
:allow-other-keys t initargs
))