1 (in-package :lisp-on-lines
)
4 ;;;; A description is an object which is used
5 ;;;; to describe another object.
9 ;;; I'm having some 'issues' with
10 ;;; compiled code and my initialization.
11 ;;; So this hack initializes the world.
12 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
13 (defparameter *defined-descriptions
* nil
))
15 (define-layered-class description-access-class
(standard-layer-class contextl
::special-layered-access-class
)
16 ((defined-in-descriptions :initarg
:in-description
)
17 (class-active-attributes-definition :initarg
:attributes
)
18 (mixin-class-p :initarg
:mixinp
)))
20 (defmethod direct-slot-definition-class
21 ((class description-access-class
) &key
&allow-other-keys
)
22 (find-class 'direct-attribute-definition-class
))
24 (defmethod effective-slot-definition-class
25 ((class description-access-class
) &key
&allow-other-keys
)
26 (find-class 'effective-attribute-definition-class
))
28 (defmethod compute-effective-slot-definition
29 ((class description-access-class
) name direct-slot-definitions
)
30 (declare (ignore name
))
31 (let ((attribute (call-next-method)))
32 (setf (attribute-direct-attributes attribute
) direct-slot-definitions
)
33 (setf (attribute-object-initargs attribute
)
34 ;; This plist will be used to init the attribute object
35 ;; Once the description itself is properly initiated.
37 'effective-attribute attribute
))
40 (defmethod slot-value-using-class ((class description-access-class
) object slotd
)
43 (eq (slot-definition-name slotd
) 'described-object
)
44 (not (slot-boundp slotd
'attribute-object
)))
46 (slot-definition-attribute-object slotd
)))
49 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
50 (defparameter *description-attributes
* (make-hash-table)))
54 (defclass standard-description-class
(description-access-class layered-class
)
55 ((attributes :accessor description-class-attributes
:initform
(list)))
56 (:default-initargs
:defining-metaclass
'description-access-class
))
60 (defmethod validate-superclass
61 ((class standard-description-class
)
62 (superclass standard-class
))
65 (define-layered-class standard-description-object
(standard-layer-object)
66 ((described-object :accessor described-object
69 (defun description-class-name (description-class)
70 (read-from-string (symbol-name (class-name description-class
))))
72 (defgeneric standard-description-p
(description-candidate)
73 (:method
(not-description)
75 (:method
((description standard-description-object
))
78 (defun compute-effective-attribute-objects (description)
81 (or (find-attribute description
82 (slot-definition-name slot
) nil
)
83 (let* ((*init-time-description
* description
)
86 (slot-value-using-class
87 (class-of description
) description slot
))
90 (apply #'make-instance
92 :description description
93 :attribute-class attribute-class
94 (attribute-object-initargs slot
))))
95 (setf (slot-definition-attribute-object slot
) attribute
))))
96 (remove 'described-object
(class-slots (class-of description
))
97 :key
#'slot-definition-name
)))
99 (defmacro with-described-object
((object description
&rest args
)
101 `(funcall-with-described-object
107 (defun initialize-effective-attribute-values-for-description-class (class description attribute-objects
)
111 :on
(partial-class-defining-classes class
) :by
#'cddr
112 :do
(funcall-with-layer-context
113 (adjoin-layer (find-layer layer
) (current-layer-context))
115 (loop :for direct-slot
:in
(class-direct-slots class
)
117 (find (slot-definition-name direct-slot
)
119 :key
#'attribute-name
)))
121 (prepare-initargs attribute
(direct-attribute-properties direct-slot
))))
123 (apply #'reinitialize-instance attribute
125 (setf (slot-value description
(attribute-name attribute
))
126 (attribute-class attribute
))
127 (apply #'change-class attribute
(find-class (attribute-class attribute
))
129 (when (slot-boundp class
'class-active-attributes-definition
)
130 (with-described-object (nil description
)
131 (setf (slot-value (find-attribute description
'active-attributes
) 'value
)
132 (slot-value class
'class-active-attributes-definition
))))))))
134 (defun initialize-description-class (class)
136 ;;; HACK: initialization does not happ en properly
137 ;;; when compiling and loading or something like that.
138 ;;; Obviously i'm not sure why.
139 ;;; So we're going to explicitly initialize things.
142 (pushnew class
*defined-descriptions
*)
146 (let* ((description (find-layer class
))
148 (setf (description-class-attributes (class-of description
))
149 (compute-effective-attribute-objects description
))))
151 (initialize-effective-attribute-values-for-description-class class description attribute-objects
)
156 ;;;; HACK: run this at startup till we figure things out.
157 (defun initialize-descriptions ()
158 (map nil
#'initialize-description-class
159 (setf *defined-descriptions
*
160 (remove-duplicates *defined-descriptions
*))))
162 (defmethod initialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '()))
163 (declare (dynamic-extent initargs
))
165 (if (loop for direct-superclass in direct-superclasses
166 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
)))
168 (apply #'call-next-method
171 (append direct-superclasses
172 (list (find-class 'standard-description-object
)))
174 (initialize-description-class class
)))
177 (defmethod reinitialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
178 (declare (dynamic-extent initargs
))
179 ; (warn "CLASS ~A ARGS ~A:" class initargs)
181 (if (or (not direct-superclasses-p
)
182 (loop for direct-superclass in direct-superclasses
183 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
))))
185 (apply #'call-next-method
188 (append direct-superclasses
189 (list (find-class 'standard-description-object
)))
191 (initialize-description-class class
)))
194 (defmethod print-object ((object standard-description-object
) stream
)
195 (print-unreadable-object (object stream
:type nil
:identity t
)
196 (format stream
"DESCRIPTION ~A" (ignore-errors (description-print-name object
)))))
198 (defmethod print-object ((object standard-description-class
) stream
)
199 (print-unreadable-object (object stream
:type t
:identity t
)
200 (princ (ignore-errors (description-print-name (find-layer object
))) stream
)))
202 (defun find-description (name &optional
(errorp t
))
203 (let ((class (find-class (defining-description name
) errorp
)))
204 (when class
(find-layer class
))))