e7c5f95a |
1 | (in-package :lisp-on-lines) |
2 | |
4358148e |
3 | (define-layered-class direct-attribute-definition-class |
4 | (special-layered-direct-slot-definition contextl::singleton-direct-slot-definition) |
5 | ((attribute-properties :accessor direct-attribute-properties |
6 | :documentation "This is an plist to hold the values of the attribute's properties as described by this direct attrbiute definition."))) |
e7c5f95a |
7 | |
4358148e |
8 | (defmethod initialize-instance :after ((attribute direct-attribute-definition-class) &rest initargs) |
80fcd57c |
9 | (setf (direct-attribute-properties attribute) initargs)) |
e7c5f95a |
10 | |
4358148e |
11 | (define-layered-class effective-attribute-definition-class (special-layered-effective-slot-definition) |
12 | ((direct-attributes :accessor attribute-direct-attributes) |
13 | (attribute-object :accessor attribute-object |
f2ff8a16 |
14 | :documentation "") |
15 | (attribute-object-initargs :accessor attribute-object-initargs))) |
e7c5f95a |
16 | |
e7c5f95a |
17 | |
4358148e |
18 | (define-layered-function attribute-value (object attribute)) |
e7c5f95a |
19 | |
4358148e |
20 | (define-layered-method attribute-value (object attribute) |
21 | |
22 | (let ((fn (handler-case (attribute-function attribute) |
23 | (unbound-slot () nil)))) |
24 | (if fn |
25 | (funcall fn object) |
26 | (%attribute-value attribute)))) |
27 | |
28 | (defmethod attribute-description (attribute) |
29 | ;(break "description for ~A is (slot-value attribute 'description-name)") |
30 | (find-layer (slot-value attribute 'description-class)) |
31 | #+nil (let ((name (slot-value attribute 'description-name))) |
32 | (when name |
33 | (find-description name)))) |
34 | |
35 | |
36 | (define-layered-class standard-attribute () |
37 | |
38 | ((effective-attribute-definition :initarg effective-attribute |
39 | :accessor attribute-effective-attribute-definition) |
40 | (description-name) |
41 | (description-class :initarg description-class) |
42 | (initfunctions :initform nil) |
f2ff8a16 |
43 | (attribute-class :accessor attribute-class |
44 | :initarg :attribute-class |
4271ab0b |
45 | :initform 'standard-attribute |
46 | :layered t) |
4358148e |
47 | (name :layered-accessor attribute-name |
48 | :initarg :name) |
49 | (label :layered-accessor attribute-label |
50 | :initarg :label |
51 | :initform nil |
52 | :layered t |
80fcd57c |
53 | :special t |
4358148e |
54 | ) |
e7c5f95a |
55 | (function |
56 | :initarg :function |
57 | :layered-accessor attribute-function |
58 | :layered t) |
4358148e |
59 | (value :layered-accessor %attribute-value |
60 | :initarg :value |
61 | :layered t))) |
62 | |
4358148e |
63 | (defmethod print-object ((object standard-attribute) stream) |
64 | (print-unreadable-object (object stream :type nil :identity t) |
65 | (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+")))) |
66 | |
4271ab0b |
67 | (defgeneric eval-property-initarg (att initarg) |
68 | (:method ((attribute standard-attribute) initarg) |
69 | nil) |
70 | (:method ((attribute standard-attribute) (initarg (eql :function))) |
71 | t)) |
72 | |
73 | (defun prepare-initargs (att args) |
74 | (loop |
75 | :for (key arg) |
76 | :on args :by #'cddr |
77 | :nconc (list key |
78 | (if (eval-property-initarg att key) |
79 | (eval arg) |
80 | arg)))) |
81 | |
4358148e |
82 | (defvar *bypass-property-layered-function* nil) |
83 | |
84 | (define-layered-function property-layered-function (description attribute-name property-name) |
85 | (:method (description attribute-name property-name) |
86 | ;(dprint "First Time PLFunction for ~A ~A ~A" description attribute-name property-name) |
87 | (ensure-layered-function |
88 | (defining-description (intern (format nil "~A-~A-~A" |
89 | (description-print-name description) |
90 | attribute-name |
91 | property-name))) |
92 | |
93 | :lambda-list '(description)))) |
94 | |
80fcd57c |
95 | |
4358148e |
96 | (define-layered-method (setf slot-value-using-layer) |
97 | :in-layer (context t) |
80fcd57c |
98 | :around |
4358148e |
99 | (new-value class (attribute standard-attribute) property writer) |
100 | |
80fcd57c |
101 | (when (or *bypass-property-layered-function* ) |
102 | |
4358148e |
103 | (return-from slot-value-using-layer (call-next-method))) |
104 | |
4358148e |
105 | (let ((layer |
80fcd57c |
106 | ;;FIXME: this is wrong for so many reasons |
4358148e |
107 | (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context)) |
80fcd57c |
108 | :key #'class-name)))) |
109 | (boundp (slot-boundp-using-class class attribute property)) |
110 | (val (real-slot-value-using-class class attribute property))) |
111 | |
112 | (when (special-symbol-p val) |
113 | (return-from slot-value-using-layer (call-next-method))) |
114 | |
115 | (when (not boundp) |
116 | ;; * This slot has never been set before. |
117 | ;; create a method on property-layered-function |
118 | ;; so subclasses can see this new property. |
119 | (ensure-layered-method |
120 | (layered-function-definer 'property-layered-function) |
121 | `(lambda (description attribute property) |
122 | (declare (ignore description attribute property)) |
123 | ,val) |
124 | :in-layer layer |
125 | :specializers |
126 | (list (class-of |
127 | (attribute-description attribute)) |
128 | (closer-mop:intern-eql-specializer |
129 | (attribute-name attribute)) |
130 | (closer-mop:intern-eql-specializer |
131 | (closer-mop:slot-definition-name property))))) |
132 | |
133 | ;; specialize this property to this description. |
134 | |
135 | (ensure-layered-method |
136 | val |
137 | `(lambda (description) |
138 | (funcall ,(lambda() |
139 | new-value))) |
140 | :in-layer layer |
141 | :specializers (list (class-of (attribute-description attribute)))) |
142 | |
143 | ;; and return the set value as is custom |
144 | (slot-value-using-class class attribute property))) |
145 | |
e7c5f95a |
146 | |
147 | (define-layered-method slot-value-using-layer |
4358148e |
148 | :in-layer (layer t) |
149 | :around (class (attribute standard-attribute) property reader) |
4358148e |
150 | |
81d70610 |
151 | ;; (dprint "Getting the slot value of ~A" property) |
4358148e |
152 | |
81d70610 |
153 | ;; We do some magic in here and i thought it |
154 | ;; would be called magically in call-next-method. |
155 | ;; This explicit call is good enough for now. |
156 | |
157 | (unless (slot-boundp-using-class class attribute property) |
158 | (slot-unbound class attribute (slot-definition-name property))) |
80fcd57c |
159 | |
160 | (let ((val (print (call-next-method)))) |
4271ab0b |
161 | |
81d70610 |
162 | (if (and |
4271ab0b |
163 | ;; Not special access |
164 | (not (symbolp val)) |
4358148e |
165 | (contextl::slot-definition-layeredp property) |
166 | (not *bypass-property-layered-function*)) |
4271ab0b |
167 | (let ((fn val)) |
4358148e |
168 | ;(dprint "... using fn ~A to get value" fn) |
169 | (funcall fn layer (attribute-description attribute))) |
4271ab0b |
170 | val))) |
4358148e |
171 | |
81d70610 |
172 | (defmacro define-bypass-function (name function-name) |
173 | `(defun ,name (&rest args) |
174 | (let ((*bypass-property-layered-function* t)) |
175 | (apply (function ,function-name) args)))) |
4358148e |
176 | |
81d70610 |
177 | (define-bypass-function real-slot-boundp-using-class slot-boundp-using-class) |
178 | (define-bypass-function real-slot-value-using-class slot-value-using-class) |
179 | (define-bypass-function (setf real-slot-value-using-class) (setf slot-value-using-class)) |
180 | |
4358148e |
181 | (defun slot-boundp-using-property-layered-function (class attribute property) |
4271ab0b |
182 | ;(dprint "plf boundp:") |
81d70610 |
183 | (let* ((really-bound-p |
184 | (real-slot-boundp-using-class class attribute property)) |
185 | (fn (if really-bound-p |
186 | (real-slot-value-using-class class attribute property) |
187 | (setf (real-slot-value-using-class class attribute property) |
188 | (property-layered-function |
189 | (attribute-description attribute) |
4358148e |
190 | (attribute-name attribute) |
81d70610 |
191 | (closer-mop:slot-definition-name property)))))) |
4271ab0b |
192 | |
4271ab0b |
193 | (if (generic-function-methods fn) |
194 | T |
80fcd57c |
195 | NIL))) |
4358148e |
196 | |
81d70610 |
197 | (define-layered-method slot-boundp-using-layer |
4358148e |
198 | :in-layer (layer t) |
199 | :around (class (attribute standard-attribute) property reader) |
80fcd57c |
200 | (if (or *bypass-property-layered-function* *symbol-access*) |
4358148e |
201 | (call-next-method) |
202 | (slot-boundp-using-property-layered-function class attribute property))) |
203 | |
204 | (defun attribute-value* (attribute) |
205 | (attribute-value *object* attribute)) |
206 | |
207 | (defmacro with-attributes (names description &body body) |
208 | `(with-slots ,names ,description ,@body)) |
209 | |
210 | (defun display-attribute (attribute) |
211 | (display-using-description attribute *display* *object*)) |
212 | |
e7c5f95a |
213 | (define-layered-method display-using-description |
214 | ((attribute standard-attribute) display object &rest args) |
4358148e |
215 | (declare (ignore args)) |
216 | (when (attribute-label attribute) |
217 | (format display "~A " (attribute-label attribute))) |
218 | (format display "~A" (attribute-value object attribute))) |
219 | |
220 | |
e7c5f95a |
221 | |
222 | |
223 | |
224 | |
225 | |
226 | |
227 | |
228 | |
229 | |