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 (defun initialize-effective-attribute-values-for-description-class (class description attribute-objects
)
103 :on
(partial-class-defining-classes class
) :by
#'cddr
104 :do
(funcall-with-layer-context
105 (adjoin-layer (find-layer layer
) (current-layer-context))
107 (loop :for direct-slot
:in
(class-direct-slots class
)
109 (find (slot-definition-name direct-slot
)
111 :key
#'attribute-name
)))
113 (prepare-initargs attribute
(direct-attribute-properties direct-slot
))))
115 (apply #'reinitialize-instance attribute
117 (setf (slot-value description
(attribute-name attribute
))
118 (attribute-class attribute
))
119 (apply #'change-class attribute
(find-class (attribute-class attribute
))
121 (when (slot-boundp class
'class-active-attributes-definition
)
122 (with-described-object (nil description
)
123 (setf (slot-value (find-attribute description
'active-attributes
) 'value
)
124 (slot-value class
'class-active-attributes-definition
))))))))
126 (defun initialize-description-class (class)
128 ;;; HACK: initialization does not happ en properly
129 ;;; when compiling and loading or something like that.
130 ;;; Obviously i'm not sure why.
131 ;;; So we're going to explicitly initialize things.
134 (pushnew class
*defined-descriptions
*)
138 (let* ((description (find-layer class
))
140 (setf (description-class-attributes (class-of description
))
141 (compute-effective-attribute-objects description
))))
143 (initialize-effective-attribute-values-for-description-class class description attribute-objects
)
148 ;;;; HACK: run this at startup till we figure things out.
149 (defun initialize-descriptions ()
150 (map nil
#'initialize-description-class
151 (setf *defined-descriptions
*
152 (remove-duplicates *defined-descriptions
*))))
154 (defmethod initialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '()))
155 (declare (dynamic-extent initargs
))
157 (if (loop for direct-superclass in direct-superclasses
158 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
)))
160 (apply #'call-next-method
163 (append direct-superclasses
164 (list (find-class 'standard-description-object
)))
166 (initialize-description-class class
)))
169 (defmethod reinitialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
170 (declare (dynamic-extent initargs
))
171 ; (warn "CLASS ~A ARGS ~A:" class initargs)
173 (if (or (not direct-superclasses-p
)
174 (loop for direct-superclass in direct-superclasses
175 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
))))
177 (apply #'call-next-method
180 (append direct-superclasses
181 (list (find-class 'standard-description-object
)))
183 (initialize-description-class class
)))
186 (defmethod print-object ((object standard-description-object
) stream
)
187 (print-unreadable-object (object stream
:type nil
:identity t
)
188 (format stream
"DESCRIPTION ~A" (ignore-errors (description-print-name object
)))))
190 (defmethod print-object ((object standard-description-class
) stream
)
191 (print-unreadable-object (object stream
:type t
:identity t
)
192 (princ (ignore-errors (description-print-name (find-layer object
))) stream
)))
194 (defun find-description (name &optional
(errorp t
))
195 (let ((class (find-class (defining-description name
) errorp
)))
196 (when class
(find-layer class
))))