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 (mixin-class-p :initarg
:mixinp
)))
19 (defmethod direct-slot-definition-class
20 ((class description-access-class
) &key
&allow-other-keys
)
21 (find-class 'direct-attribute-definition-class
))
23 (defmethod effective-slot-definition-class
24 ((class description-access-class
) &key
&allow-other-keys
)
25 (find-class 'effective-attribute-definition-class
))
27 (defmethod compute-effective-slot-definition
28 ((class description-access-class
) name direct-slot-definitions
)
29 (declare (ignore name
))
30 (let ((attribute (call-next-method)))
31 (setf (attribute-direct-attributes attribute
) direct-slot-definitions
)
32 (setf (attribute-object-initargs attribute
)
33 ;; This plist will be used to init the attribute object
34 ;; Once the description itself is properly initiated.
36 'effective-attribute attribute
))
39 (defmethod slot-value-using-class ((class description-access-class
) object slotd
)
42 (eq (slot-definition-name slotd
) 'described-object
)
43 (not (slot-boundp slotd
'attribute-object
)))
45 (slot-definition-attribute-object slotd
)))
48 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
49 (defparameter *description-attributes
* (make-hash-table)))
53 (defclass standard-description-class
(description-access-class layered-class
)
54 ((attributes :accessor description-class-attributes
:initform
(list)))
55 (:default-initargs
:defining-metaclass
'description-access-class
))
59 (defmethod validate-superclass
60 ((class standard-description-class
)
61 (superclass standard-class
))
64 (define-layered-class standard-description-object
(standard-layer-object)
65 ((described-object :accessor described-object
68 (defun description-class-name (description-class)
69 (read-from-string (symbol-name (class-name description-class
))))
71 (defgeneric standard-description-p
(description-candidate)
72 (:method
(not-description)
74 (:method
((description standard-description-object
))
77 (defun initialize-description-class (class)
79 ;;; HACK: initialization does not happ en properly
80 ;;; when compiling and loading or something like that.
81 ;;; Obviously i'm not sure why.
82 ;;; So we're going to explicitly initialize things.
85 (pushnew class
*defined-descriptions
*)
89 (let* ((description (find-layer class
))
91 (setf (description-class-attributes (class-of description
))
94 (or (find-attribute description
95 (slot-definition-name slot
) nil
)
96 (let* ((*init-time-description
* description
)
99 (slot-value-using-class
100 (class-of description
) description slot
))
101 'standard-attribute
))
103 (apply #'make-instance
105 :description description
106 :attribute-class attribute-class
107 (attribute-object-initargs slot
))))
108 (setf (slot-definition-attribute-object slot
) attribute
))))
109 (remove 'described-object
(class-slots (class-of description
))
110 :key
#'slot-definition-name
))))
112 (partial-class-defining-classes class
)))
116 :on defining-classes
:by
#'cddr
117 :do
(funcall-with-layer-context
118 (adjoin-layer (find-layer layer
) (current-layer-context))
120 (loop :for direct-slot
:in
(class-direct-slots class
)
122 (find (slot-definition-name direct-slot
)
124 :key
#'attribute-name
)))
126 (prepare-initargs attribute
(direct-attribute-properties direct-slot
))))
128 (apply #'reinitialize-instance attribute
130 (setf (slot-value description
(attribute-name attribute
))
131 (attribute-class attribute
))
132 (apply #'change-class attribute
(find-class (attribute-class attribute
))
136 #+old
(defun initialize-description-class (class)
138 ;;; HACK: initialization does not happ en properly
139 ;;; when compiling and loading or something like that.
140 ;;; Obviously i'm not sure why.
141 ;;; So we're going to explicitly initialize things.
144 (pushnew class
*defined-descriptions
*)
148 (let* ((description (find-layer class
))
152 (let* ((*init-time-description
* description
)
154 (apply #'make-instance
156 :description description
157 (attribute-object-initargs slot
))))
160 (setf (slot-definition-attribute-object slot
) attribute
)))
161 (remove 'described-object
(class-slots (class-of description
))
162 :key
#'slot-definition-name
)))
163 (defining-classes (partial-class-defining-classes (class-of description
))))
167 :on defining-classes
:by
#'cddr
168 :do
(funcall-with-layer-context
169 (adjoin-layer (find-layer layer
) (current-layer-context))
171 (loop :for direct-slot
:in
(class-direct-slots class
)
173 (find (slot-definition-name direct-slot
)
175 :key
#'attribute-name
)))
177 (prepare-initargs attribute
(direct-attribute-properties direct-slot
))))
179 (apply #'reinitialize-instance attribute
181 (warn "Attribute class for ~A is ~A" attribute
(attribute-class attribute
))
182 (when (not (eq (find-class (attribute-class attribute
))
183 (class-of attribute
)))
184 (warn "~%CHANGING CLASS~%")
186 (apply #'change-class attribute
(attribute-class attribute
)
189 ;;;; HACK: run this at startup till we figure things out.
190 (defun initialize-descriptions ()
191 (map nil
#'initialize-description-class
192 (setf *defined-descriptions
*
193 (remove-duplicates *defined-descriptions
*))))
195 (defmethod initialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '()))
196 (declare (dynamic-extent initargs
))
198 (if (loop for direct-superclass in direct-superclasses
199 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
)))
201 (apply #'call-next-method
204 (append direct-superclasses
205 (list (find-class 'standard-description-object
)))
207 (initialize-description-class class
)))
210 (defmethod reinitialize-instance :around
((class standard-description-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
211 (declare (dynamic-extent initargs
))
212 ; (warn "CLASS ~A ARGS ~A:" class initargs)
214 (if (or (not direct-superclasses-p
)
215 (loop for direct-superclass in direct-superclasses
216 thereis
(ignore-errors (subtypep direct-superclass
'standard-description-object
))))
218 (apply #'call-next-method
221 (append direct-superclasses
222 (list (find-class 'standard-description-object
)))
224 (initialize-description-class class
)))
227 (defmethod print-object ((object standard-description-object
) stream
)
228 (print-unreadable-object (object stream
:type nil
:identity t
)
229 (format stream
"DESCRIPTION ~A" (ignore-errors (description-print-name object
)))))
231 (defmethod print-object ((object standard-description-class
) stream
)
232 (print-unreadable-object (object stream
:type t
:identity t
)
233 (princ (ignore-errors (description-print-name (find-layer object
))) stream
)))
235 (defun find-description (name &optional
(errorp t
))
236 (let ((class (find-class (defining-description name
) errorp
)))
237 (when class
(find-layer class
))))