tons of small changes to bring this up to date with maxclaims 2.0
[clinton/lisp-on-lines.git] / src / description-class.lisp
CommitLineData
4867c86f 1(in-package :lisp-on-lines)
2
4358148e 3;;;; * DESCRIPTIONS
4;;;; A description is an object which is used
5;;;; to describe another object.
6
4358148e 7
8;;; #+HACK
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))
14
4271ab0b 15(define-layered-class description-access-class (standard-layer-class contextl::special-layered-access-class )
4358148e 16 ((defined-in-descriptions :initarg :in-description)
1178c783 17 (class-active-attributes-definition :initarg :attributes)
4358148e 18 (mixin-class-p :initarg :mixinp)))
19
20(defmethod direct-slot-definition-class
21 ((class description-access-class) &key &allow-other-keys)
22 (find-class 'direct-attribute-definition-class))
23
24(defmethod effective-slot-definition-class
25 ((class description-access-class) &key &allow-other-keys)
26 (find-class 'effective-attribute-definition-class))
27
28(defmethod compute-effective-slot-definition
29 ((class description-access-class) name direct-slot-definitions)
4867c86f 30 (declare (ignore name))
4358148e 31 (let ((attribute (call-next-method)))
32 (setf (attribute-direct-attributes attribute) direct-slot-definitions)
f2ff8a16 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.
36 (list :name name
e8d4fa45 37 'effective-attribute attribute))
4358148e 38 attribute))
e8d4fa45 39
40(defmethod slot-value-using-class ((class description-access-class) object slotd)
b7657b86 41 (call-next-method)
42#+nil (if (or
e8d4fa45 43 (eq (slot-definition-name slotd) 'described-object)
44 (not (slot-boundp slotd 'attribute-object)))
45 (call-next-method)
46 (slot-definition-attribute-object slotd)))
4867c86f 47
4358148e 48
b7657b86 49(eval-when (:compile-toplevel :load-toplevel :execute)
50 (defparameter *description-attributes* (make-hash-table)))
51
52
53
4358148e 54(defclass standard-description-class (description-access-class layered-class)
b7657b86 55 ((attributes :accessor description-class-attributes :initform (list)))
4358148e 56 (:default-initargs :defining-metaclass 'description-access-class))
57
b7657b86 58
59
4358148e 60(defmethod validate-superclass
61 ((class standard-description-class)
62 (superclass standard-class))
63 t)
64
e8d4fa45 65(define-layered-class standard-description-object (standard-layer-object)
66 ((described-object :accessor described-object
67 :special t)))
4358148e 68
69(defun description-class-name (description-class)
70 (read-from-string (symbol-name (class-name description-class))))
b7657b86 71
72(defgeneric standard-description-p (description-candidate)
73 (:method (not-description)
74 NIL)
75 (:method ((description standard-description-object))
76 T))
b7657b86 77
1178c783 78(defun compute-effective-attribute-objects (description)
79 (mapcar
80 (lambda (slot)
81 (or (find-attribute description
82 (slot-definition-name slot) nil)
83 (let* ((*init-time-description* description)
84 (attribute-class (or
85 (ignore-errors
86 (slot-value-using-class
87 (class-of description) description slot))
88 'standard-attribute))
89 (attribute
90 (apply #'make-instance
91 attribute-class
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)))
98
f56d6e7e 99(defmacro with-described-object ((object description &rest args)
100 &body body)
101 `(funcall-with-described-object
102 (lambda () ,@body)
103 ,object
104 ,description
105 ,@args))
106
1178c783 107(defun initialize-effective-attribute-values-for-description-class (class description attribute-objects)
b7657b86 108
109 (loop
110 :for (layer class)
1178c783 111 :on (partial-class-defining-classes class) :by #'cddr
b7657b86 112 :do (funcall-with-layer-context
113 (adjoin-layer (find-layer layer) (current-layer-context))
114 (lambda ()
115 (loop :for direct-slot :in (class-direct-slots class)
116 :do (let ((attribute
117 (find (slot-definition-name direct-slot)
118 attribute-objects
119 :key #'attribute-name)))
120 (let ((initargs
121 (prepare-initargs attribute (direct-attribute-properties direct-slot))))
122
123 (apply #'reinitialize-instance attribute
124 initargs )
125 (setf (slot-value description (attribute-name attribute))
126 (attribute-class attribute))
3d5707d5 127 (apply #'change-class attribute (find-class (attribute-class attribute))
1178c783 128 initargs))))
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))))))))
133
134(defun initialize-description-class (class)
135
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.
140;;; For now. --drewc
141
142 (pushnew class *defined-descriptions*)
143
144;;; ENDHACK.
145
146 (let* ((description (find-layer class))
147 (attribute-objects
148 (setf (description-class-attributes (class-of description))
149 (compute-effective-attribute-objects description))))
150
151 (initialize-effective-attribute-values-for-description-class class description attribute-objects)
152))
b7657b86 153
154
4358148e 155
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*))))
161
162(defmethod initialize-instance :around ((class standard-description-class) &rest initargs &key (direct-superclasses '()))
163 (declare (dynamic-extent initargs))
164 (prog1
165 (if (loop for direct-superclass in direct-superclasses
166 thereis (ignore-errors (subtypep direct-superclass 'standard-description-object)))
167 (call-next-method)
168 (apply #'call-next-method
169 class
170 :direct-superclasses
171 (append direct-superclasses
172 (list (find-class 'standard-description-object)))
173 initargs))
174 (initialize-description-class class)))
175
176
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)
180 (prog1
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))))
184 (call-next-method)
185 (apply #'call-next-method
186 class
187 :direct-superclasses
188 (append direct-superclasses
189 (list (find-class 'standard-description-object)))
190 initargs))
191 (initialize-description-class class)))
192
193
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)))))
197
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)))
201
3d5707d5 202(defun find-description (name &optional (errorp t))
203 (let ((class (find-class (defining-description name) errorp)))
204 (when class (find-layer class))))
4358148e 205
206
207
4867c86f 208
209
210