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