1 (in-package :lisp-on-lines
)
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.")))
8 (defmethod initialize-instance :after
((attribute direct-attribute-definition-class
) &rest initargs
)
9 (setf (direct-attribute-properties attribute
) initargs
))
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
15 (attribute-object-initargs :accessor attribute-object-initargs
)))
18 (define-layered-function attribute-value
(object attribute
))
20 (define-layered-method attribute-value
(object attribute
)
22 (let ((fn (handler-case (attribute-function attribute
)
23 (unbound-slot () nil
))))
26 (%attribute-value attribute
))))
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
)))
33 (find-description name
))))
36 (define-layered-class standard-attribute
()
38 ((effective-attribute-definition :initarg effective-attribute
39 :accessor attribute-effective-attribute-definition
)
41 (description-class :initarg description-class
)
42 (initfunctions :initform nil
)
43 (attribute-class :accessor attribute-class
44 :initarg
:attribute-class
45 :initform
'standard-attribute
47 (name :layered-accessor attribute-name
49 (label :layered-accessor attribute-label
57 :layered-accessor attribute-function
59 (value :layered-accessor %attribute-value
65 (defmethod print-object ((object standard-attribute
) stream
)
66 (print-unreadable-object (object stream
:type nil
:identity t
)
67 (format stream
"ATTRIBUTE ~A" (or (ignore-errors (attribute-name object
)) "+unnamed-attribute+"))))
69 (defgeneric eval-property-initarg
(att initarg
)
70 (:method
((attribute standard-attribute
) initarg
)
72 (:method
((attribute standard-attribute
) (initarg (eql :function
)))
75 (defun prepare-initargs (att args
)
80 (if (eval-property-initarg att key
)
84 (defvar *bypass-property-layered-function
* nil
)
86 (define-layered-function property-layered-function
(description attribute-name property-name
)
87 (:method
(description attribute-name property-name
)
88 ;(dprint "First Time PLFunction for ~A ~A ~A" description attribute-name property-name)
89 (ensure-layered-function
90 (defining-description (intern (format nil
"~A-~A-~A"
91 (description-print-name description
)
95 :lambda-list
'(description))))
97 (define-layered-method (setf slot-value-using-layer
)
99 (new-value class
(attribute standard-attribute
) property writer
)
101 (when (or *bypass-property-layered-function
*)
102 (return-from slot-value-using-layer
(call-next-method)))
105 ;;FIXME: this is wrong for so many reasons.
107 (find-layer (first (remove nil
(closer-mop::class-precedence-list
(class-of context
))
108 :key
#'class-name
)))))
111 (flet ((do-set-slot()
114 (let ((*bypass-property-layered-function
* t
))
115 (if (slot-boundp-using-class class attribute property
)
116 (slot-value-using-class class attribute property
)
117 (setf (slot-value-using-class class attribute property
)
118 (property-layered-function
119 (attribute-description attribute
)
120 (attribute-name attribute
)
121 (closer-mop:slot-definition-name property
)))))))
122 ;(dprint "We are setting the fn ~A " fn)
123 (when (not (generic-function-methods fn
))
124 ; (dprint "... there are no methods on it ever")
125 ;; * This slot has never been set before.
126 ;; create a method on property-layered-function
127 ;; so subclasses can see this new property.
128 (ensure-layered-method
129 (layered-function-definer 'property-layered-function
)
130 `(lambda (description attribute property
)
131 (declare (ignore description attribute property
))
136 (attribute-description attribute
))
137 (closer-mop:intern-eql-specializer
138 (attribute-name attribute
))
139 (closer-mop:intern-eql-specializer
140 (closer-mop:slot-definition-name property
)))))
143 ;; finally, specialize this property to this description.
144 (ensure-layered-method
146 `(lambda (description)
150 :specializers
(list (class-of (attribute-description attribute
)
153 (if (slot-boundp attribute
'description-class
)
155 (error "serrint wif no desc WTF!")))))
158 (define-layered-method slot-value-using-layer
160 :around
(class (attribute standard-attribute
) property reader
)
162 ;; (dprint "Getting the slot value of ~A" property)
164 ;; We do some magic in here and i thought it
165 ;; would be called magically in call-next-method.
166 ;; This explicit call is good enough for now.
168 (unless (slot-boundp-using-class class attribute property
)
169 (slot-unbound class attribute
(slot-definition-name property
)))
171 (let ((val (call-next-method)))
174 ;; Not special access
176 (contextl::slot-definition-layeredp property
)
177 (not *bypass-property-layered-function
*))
179 ;(dprint "... using fn ~A to get value" fn)
180 (funcall fn layer
(attribute-description attribute
)))
183 (defmacro define-bypass-function
(name function-name
)
184 `(defun ,name
(&rest args
)
185 (let ((*bypass-property-layered-function
* t
))
186 (apply (function ,function-name
) args
))))
188 (define-bypass-function real-slot-boundp-using-class slot-boundp-using-class
)
189 (define-bypass-function real-slot-value-using-class slot-value-using-class
)
190 (define-bypass-function (setf real-slot-value-using-class
) (setf slot-value-using-class
))
192 (defun slot-boundp-using-property-layered-function (class attribute property
)
193 ;(dprint "plf boundp:")
194 (let* ((really-bound-p
195 (real-slot-boundp-using-class class attribute property
))
196 (fn (if really-bound-p
197 (real-slot-value-using-class class attribute property
)
198 (setf (real-slot-value-using-class class attribute property
)
199 (property-layered-function
200 (attribute-description attribute
)
201 (attribute-name attribute
)
202 (closer-mop:slot-definition-name property
))))))
205 ;;special symbol access in process
207 (if (generic-function-methods fn
)
211 (define-layered-method slot-boundp-using-layer
213 :around
(class (attribute standard-attribute
) property reader
)
214 (if *bypass-property-layered-function
*
216 (slot-boundp-using-property-layered-function class attribute property
)))
218 (defun attribute-value* (attribute)
219 (attribute-value *object
* attribute
))
221 (defmacro with-attributes
(names description
&body body
)
222 `(with-slots ,names
,description
,@body
))
224 (defun display-attribute (attribute)
225 (display-using-description attribute
*display
* *object
*))
227 (define-layered-method display-using-description
228 ((attribute standard-attribute
) display object
&rest args
)
229 (declare (ignore args
))
230 (when (attribute-label attribute
)
231 (format display
"~A " (attribute-label attribute
)))
232 (format display
"~A" (attribute-value object attribute
)))