Add dlambda + contextl hack
[clinton/lisp-on-lines.git] / src / contextl-hacks.lisp
1 (in-package :contextl)
2
3
4 (defmethod contextl:layer-name :around (layer)
5 (or (call-next-method) layer))
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
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
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)))
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))))