4358148e |
1 | (in-package :contextl) |
2 | |
b7657b86 |
3 | |
8032a7fe |
4 | (defmethod contextl:layer-name :around (layer) |
5 | (or (call-next-method) layer)) |
b7657b86 |
6 | |
7 | ;;; HACK: |
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. |
11 | |
12 | ;;; TODO: investigate switching to deflayer! |
13 | |
14 | (defun contextl::prepare-layer (layer) |
15 | (if (symbolp layer) |
16 | (if (eq (symbol-package layer) |
17 | (find-package :description-definers)) |
18 | layer |
19 | (contextl::defining-layer layer)) |
20 | |
21 | layer)) |
22 | |
23 | (defmethod find-layer-class :around ((layer symbol) &optional errorp environment) |
24 | (if (eq (symbol-package layer) |
25 | (find-package :description-definers)) |
26 | (find-class layer) |
27 | (call-next-method))) |
28 | |
29 | |
8032a7fe |
30 | ;;; HACK: There are classes named NIL (partial classes) in the superclass list. |
4358148e |
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 |
33 | ;;; a confict. |
34 | ;;; Since we don't care about these classes (?) this might work (?) |
35 | |
36 | (defmethod initialize-instance :around |
37 | ((class special-class) &rest initargs |
38 | &key direct-superclasses) |
39 | (declare (dynamic-extent initargs)) |
40 | (if (or |
41 | ;; HACK begins |
42 | (not (ignore-errors (class-name class))) |
43 | ;; ENDHACK |
44 | (loop for superclass in direct-superclasses |
45 | thereis (ignore-errors (subtypep superclass 'special-object)))) |
46 | (call-next-method) |
47 | (progn (apply #'call-next-method class |
48 | :direct-superclasses |
49 | (append direct-superclasses |
50 | (list (find-class 'special-object))) |
51 | initargs)))) |
52 | |
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)) |
60 | ;endhack |
61 | (loop for superclass in direct-superclasses |
62 | thereis (ignore-errors (subtypep superclass 'special-object)))) |
63 | (call-next-method) |
64 | (apply #'call-next-method class |
65 | :direct-superclasses |
66 | (append direct-superclasses |
67 | (list |
68 | (find-class 'special-object))) |
69 | initargs))) |
6de8d300 |
70 | (call-next-method)) |
71 | |
72 | |
73 | |
74 | (defun funcall-with-special-initargs (bindings thunk) |
75 | (let ((arg-count 0)) |
76 | (special-symbol-progv |
77 | (loop for (object . initargs) in bindings |
78 | for initarg-keys = (loop for key in initargs by #'cddr |
79 | collect key into keys |
80 | count t into count |
81 | finally (incf arg-count count) |
82 | (return keys)) |
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)) |
91 | (funcall thunk)))) |