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) |
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 |
14 | :documentation ""))) |
e7c5f95a |
15 | |
e7c5f95a |
16 | |
4358148e |
17 | (define-layered-function attribute-value (object attribute)) |
e7c5f95a |
18 | |
4358148e |
19 | (define-layered-method attribute-value (object attribute) |
20 | |
21 | (let ((fn (handler-case (attribute-function attribute) |
22 | (unbound-slot () nil)))) |
23 | (if fn |
24 | (funcall fn object) |
25 | (%attribute-value attribute)))) |
26 | |
27 | (defmethod attribute-description (attribute) |
28 | ;(break "description for ~A is (slot-value attribute 'description-name)") |
29 | (find-layer (slot-value attribute 'description-class)) |
30 | #+nil (let ((name (slot-value attribute 'description-name))) |
31 | (when name |
32 | (find-description name)))) |
33 | |
34 | |
35 | (define-layered-class standard-attribute () |
36 | |
37 | ((effective-attribute-definition :initarg effective-attribute |
38 | :accessor attribute-effective-attribute-definition) |
39 | (description-name) |
40 | (description-class :initarg description-class) |
41 | (initfunctions :initform nil) |
42 | (attribute-class :accessor attribute-class :initarg :attribute-class :initform 'standard-attribute) |
43 | (name :layered-accessor attribute-name |
44 | :initarg :name) |
45 | (label :layered-accessor attribute-label |
46 | :initarg :label |
47 | :initform nil |
48 | :layered t |
49 | ;:special t |
50 | ) |
e7c5f95a |
51 | (function |
52 | :initarg :function |
53 | :layered-accessor attribute-function |
54 | :layered t) |
4358148e |
55 | (value :layered-accessor %attribute-value |
56 | :initarg :value |
57 | :layered t))) |
58 | |
59 | |
60 | |
61 | (defmethod print-object ((object standard-attribute) stream) |
62 | (print-unreadable-object (object stream :type nil :identity t) |
63 | (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+")))) |
64 | |
65 | (defvar *bypass-property-layered-function* nil) |
66 | |
67 | (define-layered-function property-layered-function (description attribute-name property-name) |
68 | (:method (description attribute-name property-name) |
69 | ;(dprint "First Time PLFunction for ~A ~A ~A" description attribute-name property-name) |
70 | (ensure-layered-function |
71 | (defining-description (intern (format nil "~A-~A-~A" |
72 | (description-print-name description) |
73 | attribute-name |
74 | property-name))) |
75 | |
76 | :lambda-list '(description)))) |
77 | |
78 | (define-layered-method (setf slot-value-using-layer) |
79 | :in-layer (context t) |
80 | (new-value class (attribute standard-attribute) property writer) |
81 | |
82 | (when (or *bypass-property-layered-function* |
83 | (not (slot-definition-layeredp property))) |
84 | (return-from slot-value-using-layer (call-next-method))) |
85 | |
86 | |
87 | ;;FIXME: this is wrong for so many reasons. |
88 | (let ((layer |
89 | (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context)) |
90 | :key #'class-name))))) |
91 | |
92 | |
93 | (flet ((do-set-slot() |
94 | |
95 | (let ((fn |
96 | (let ((*bypass-property-layered-function* t)) |
97 | (if (slot-boundp-using-class class attribute property) |
98 | (slot-value-using-class class attribute property) |
99 | (setf (slot-value-using-class class attribute property) |
100 | (property-layered-function |
101 | (attribute-description attribute) |
102 | (attribute-name attribute) |
103 | (closer-mop:slot-definition-name property))))))) |
104 | ;(dprint "We are setting the fn ~A " fn) |
105 | (when (not (generic-function-methods fn)) |
106 | ; (dprint "... there are no methods on it ever") |
107 | ;; * This slot has never been set before. |
108 | ;; create a method on property-layered-function |
109 | ;; so subclasses can see this new property. |
110 | (ensure-layered-method |
111 | (layered-function-definer 'property-layered-function) |
112 | `(lambda (description attribute property) |
113 | (declare (ignore description attribute property)) |
114 | ,fn) |
115 | :in-layer layer |
116 | :specializers |
117 | (list (class-of |
118 | (attribute-description attribute)) |
119 | (closer-mop:intern-eql-specializer |
120 | (attribute-name attribute)) |
121 | (closer-mop:intern-eql-specializer |
122 | (closer-mop:slot-definition-name property))))) |
123 | |
124 | |
125 | ;; finally, specialize this property to this description. |
126 | (ensure-layered-method |
127 | fn |
128 | `(lambda (description) |
129 | ,new-value) |
130 | :in-layer layer |
131 | :specializers (list (class-of (attribute-description attribute) |
132 | )))))) |
133 | |
134 | (if (slot-boundp attribute 'description-class) |
135 | (do-set-slot) |
136 | (push (lambda () (do-set-slot)) |
137 | (slot-value attribute 'initfunctions)))))) |
e7c5f95a |
138 | |
e7c5f95a |
139 | |
140 | (define-layered-method slot-value-using-layer |
4358148e |
141 | :in-layer (layer t) |
142 | :around (class (attribute standard-attribute) property reader) |
143 | ;(dprint "Getting the slot value of ~A" property) |
144 | |
145 | (when (not (slot-boundp-using-class class attribute property)) |
146 | ;; If the slot is unbound, we search for its layered-function |
147 | |
148 | (let ((fn (property-layered-function |
149 | (attribute-description attribute) |
150 | |
151 | (attribute-name attribute) |
152 | (closer-mop:slot-definition-name property)))) |
153 | (dprint ".. not bound yet, have function ~A" fn) |
154 | (if (generic-function-methods fn) |
155 | (let ((*bypass-property-layered-function* t)) |
156 | ; (dprint " This shit has been bound!. We gona set the _real_ slot to the generic function like.") |
157 | (setf (slot-value-using-class class attribute property) fn)) |
158 | (progn |
159 | ;(dprint "This shit aint never been bound nowhere! checking for initfunction...") |
160 | (when (slot-definition-initfunction property) |
161 | ;(dprint "At least we have an initfunction. sweeet") |
162 | (let ((*bypass-property-layered-function* nil)) |
163 | (setf (slot-value attribute (slot-definition-name property)) |
164 | (funcall (slot-definition-initfunction property))))))))) |
165 | |
166 | ;(dprint "If we're here, the slot should be bound") |
167 | |
168 | |
169 | (if (and |
170 | (contextl::slot-definition-layeredp property) |
171 | (not *bypass-property-layered-function*)) |
172 | (let ((fn (call-next-method))) |
173 | ;(dprint "... using fn ~A to get value" fn) |
174 | (funcall fn layer (attribute-description attribute))) |
175 | (call-next-method))) |
176 | |
177 | |
178 | |
179 | |
180 | (defun slot-boundp-using-property-layered-function (class attribute property) |
181 | (when (not |
182 | (let ((*bypass-property-layered-function* t)) |
183 | (slot-boundp-using-class class attribute property))) |
184 | ;; If the slot is unbound, we search for its layered-function |
185 | |
186 | (let ((fn (property-layered-function |
187 | (attribute-description attribute) |
188 | |
189 | (attribute-name attribute) |
190 | (closer-mop:slot-definition-name property)))) |
191 | (if (generic-function-methods fn) |
192 | (let ((*bypass-property-layered-function* t)) |
193 | (setf (slot-value-using-class class attribute property) fn)) |
194 | NIL)))) |
195 | |
196 | #+nil(define-layered-method slot-boundp-using-layer |
197 | :in-layer (layer t) |
198 | :around (class (attribute standard-attribute) property reader) |
199 | (if *bypass-property-layered-function* |
200 | (call-next-method) |
201 | (slot-boundp-using-property-layered-function class attribute property))) |
202 | |
203 | (defun attribute-value* (attribute) |
204 | (attribute-value *object* attribute)) |
205 | |
206 | (defmacro with-attributes (names description &body body) |
207 | `(with-slots ,names ,description ,@body)) |
208 | |
209 | (defun display-attribute (attribute) |
210 | (display-using-description attribute *display* *object*)) |
211 | |
e7c5f95a |
212 | (define-layered-method display-using-description |
213 | ((attribute standard-attribute) display object &rest args) |
4358148e |
214 | (declare (ignore args)) |
215 | (when (attribute-label attribute) |
216 | (format display "~A " (attribute-label attribute))) |
217 | (format display "~A" (attribute-value object attribute))) |
218 | |
219 | |
e7c5f95a |
220 | |
221 | |
222 | |
223 | |
224 | |
225 | |
226 | |
227 | |
228 | |