Properties are special now!
[clinton/lisp-on-lines.git] / src / contextl-hacks.lisp
1 (in-package :contextl)
2
3 ;;; HACK: We are ending up with classes named NIL in the superclass list.
4 ;;; These cannot be given the special object superclass when re-initializing
5 ;;; is it will be in the subclasses superclasses AFTER this class, causing
6 ;;; a confict.
7 ;;; Since we don't care about these classes (?) this might work (?)
8
9 (defmethod initialize-instance :around
10 ((class special-class) &rest initargs
11 &key direct-superclasses)
12 (declare (dynamic-extent initargs))
13 (if (or
14 ;; HACK begins
15 (not (ignore-errors (class-name class)))
16 ;; ENDHACK
17 (loop for superclass in direct-superclasses
18 thereis (ignore-errors (subtypep superclass 'special-object))))
19 (call-next-method)
20 (progn (apply #'call-next-method class
21 :direct-superclasses
22 (append direct-superclasses
23 (list (find-class 'special-object)))
24 initargs))))
25
26 (defmethod reinitialize-instance :around
27 ((class special-class) &rest initargs
28 &key (direct-superclasses () direct-superclasses-p))
29 (declare (dynamic-extent initargs))
30 (if direct-superclasses-p
31 (if (or ; Here comes the hack
32 (not (class-name class))
33 ;endhack
34 (loop for superclass in direct-superclasses
35 thereis (ignore-errors (subtypep superclass 'special-object))))
36 (call-next-method)
37 (apply #'call-next-method class
38 :direct-superclasses
39 (append direct-superclasses
40 (list
41 (find-class 'special-object)))
42 initargs)))
43 (call-next-method))
44
45
46
47 (defun funcall-with-special-initargs (bindings thunk)
48 (let ((arg-count 0))
49 (special-symbol-progv
50 (loop for (object . initargs) in bindings
51 for initarg-keys = (loop for key in initargs by #'cddr
52 collect key into keys
53 count t into count
54 finally (incf arg-count count)
55 (return keys))
56 nconc (loop for slot in (class-slots (class-of object))
57 when (and (slot-definition-specialp slot)
58 (intersection initarg-keys (slot-definition-initargs slot)))
59 collect (with-symbol-access
60 (slot-value object (slot-definition-name slot)))))
61 (make-list arg-count :initial-element nil)
62 (loop for (object . initargs) in bindings
63 do (apply #'shared-initialize object nil :allow-other-keys t initargs))
64 (funcall thunk))))