1 | ;;; defclass.lisp |
---|
2 | ;;; |
---|
3 | ;;; Copyright (C) 2003 Peter Graves |
---|
4 | ;;; $Id: defclass.lisp,v 1.4 2003-10-10 17:17:24 piso Exp $ |
---|
5 | ;;; |
---|
6 | ;;; This program is free software; you can redistribute it and/or |
---|
7 | ;;; modify it under the terms of the GNU General Public License |
---|
8 | ;;; as published by the Free Software Foundation; either version 2 |
---|
9 | ;;; of the License, or (at your option) any later version. |
---|
10 | ;;; |
---|
11 | ;;; This program is distributed in the hope that it will be useful, |
---|
12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
---|
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
---|
14 | ;;; GNU General Public License for more details. |
---|
15 | ;;; |
---|
16 | ;;; You should have received a copy of the GNU General Public License |
---|
17 | ;;; along with this program; if not, write to the Free Software |
---|
18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
---|
19 | |
---|
20 | (in-package "SYSTEM") |
---|
21 | |
---|
22 | (defmacro push-on-end (value location) |
---|
23 | `(setf ,location (nconc ,location (list ,value)))) |
---|
24 | |
---|
25 | ;;; (SETF GETF*) is like (SETF GETF) except that it always changes the list, |
---|
26 | ;;; which must be non-nil. |
---|
27 | |
---|
28 | (defun (setf getf*) (new-value plist key) |
---|
29 | (block body |
---|
30 | (do ((x plist (cddr x))) |
---|
31 | ((null x)) |
---|
32 | (when (eq (car x) key) |
---|
33 | (setf (car (cdr x)) new-value) |
---|
34 | (return-from body new-value))) |
---|
35 | (push-on-end key plist) |
---|
36 | (push-on-end new-value plist) |
---|
37 | new-value)) |
---|
38 | |
---|
39 | (defun mapappend (fun &rest args) |
---|
40 | (if (some #'null args) |
---|
41 | () |
---|
42 | (append (apply fun (mapcar #'car args)) |
---|
43 | (apply #'mapappend fun (mapcar #'cdr args))))) |
---|
44 | |
---|
45 | (defun mapplist (fun x) |
---|
46 | (if (null x) |
---|
47 | () |
---|
48 | (cons (funcall fun (car x) (cadr x)) |
---|
49 | (mapplist fun (cddr x))))) |
---|
50 | |
---|
51 | (defsetf class-name %set-class-name) |
---|
52 | (defsetf class-direct-superclasses %set-class-direct-superclasses) |
---|
53 | (defsetf class-direct-subclasses %set-class-direct-subclasses) |
---|
54 | (defsetf class-direct-methods %set-class-direct-methods) |
---|
55 | (defsetf class-direct-slots %set-class-direct-slots) |
---|
56 | (defsetf class-precedence-list %set-class-precedence-list) |
---|
57 | (defsetf class-slots %set-class-slots) |
---|
58 | |
---|
59 | (defun canonicalize-direct-slots (direct-slots) |
---|
60 | `(list ,@(mapcar #'canonicalize-direct-slot direct-slots))) |
---|
61 | |
---|
62 | (defun canonicalize-direct-slot (spec) |
---|
63 | (if (symbolp spec) |
---|
64 | `(list :name ',spec) |
---|
65 | (let ((name (car spec)) |
---|
66 | (initfunction nil) |
---|
67 | (initform nil) |
---|
68 | (initargs ()) |
---|
69 | (readers ()) |
---|
70 | (writers ()) |
---|
71 | (other-options ())) |
---|
72 | (do ((olist (cdr spec) (cddr olist))) |
---|
73 | ((null olist)) |
---|
74 | (case (car olist) |
---|
75 | (:initform |
---|
76 | (setq initfunction |
---|
77 | `(function (lambda () ,(cadr olist)))) |
---|
78 | (setq initform `',(cadr olist))) |
---|
79 | (:initarg |
---|
80 | (push-on-end (cadr olist) initargs)) |
---|
81 | (:reader |
---|
82 | (push-on-end (cadr olist) readers)) |
---|
83 | (:writer |
---|
84 | (push-on-end (cadr olist) writers)) |
---|
85 | (:accessor |
---|
86 | (push-on-end (cadr olist) readers) |
---|
87 | (push-on-end `(setf ,(cadr olist)) writers)) |
---|
88 | (otherwise |
---|
89 | (push-on-end `',(car olist) other-options) |
---|
90 | (push-on-end `',(cadr olist) other-options)))) |
---|
91 | `(list |
---|
92 | :name ',name |
---|
93 | ,@(when initfunction |
---|
94 | `(:initform ,initform |
---|
95 | :initfunction ,initfunction)) |
---|
96 | ,@(when initargs `(:initargs ',initargs)) |
---|
97 | ,@(when readers `(:readers ',readers)) |
---|
98 | ,@(when writers `(:writers ',writers)) |
---|
99 | ,@other-options)))) |
---|
100 | |
---|
101 | (defun canonicalize-direct-superclasses (direct-superclasses) |
---|
102 | `(list ,@(mapcar #'canonicalize-direct-superclass direct-superclasses))) |
---|
103 | |
---|
104 | (defun canonicalize-direct-superclass (class-name) |
---|
105 | `(find-class ',class-name)) |
---|
106 | |
---|
107 | (defun canonicalize-defclass-options (options) |
---|
108 | (mapappend #'canonicalize-defclass-option options)) |
---|
109 | |
---|
110 | (defun canonicalize-defclass-option (option) |
---|
111 | (case (car option) |
---|
112 | (:metaclass |
---|
113 | (list ':metaclass |
---|
114 | `(find-class ',(cadr option)))) |
---|
115 | (:default-initargs |
---|
116 | (list |
---|
117 | ':direct-default-initargs |
---|
118 | `(list ,@(mapappend |
---|
119 | #'(lambda (x) x) |
---|
120 | (mapplist |
---|
121 | #'(lambda (key value) |
---|
122 | `(',key ,value)) |
---|
123 | (cdr option)))))) |
---|
124 | (t (list `',(car option) `',(cadr option))))) |
---|
125 | |
---|
126 | ;;; Slot definition metaobjects |
---|
127 | |
---|
128 | ;;; N.B. Quietly retain all unknown slot options (rather than signaling an |
---|
129 | ;;; error), so that it's easy to add new ones. |
---|
130 | |
---|
131 | (defun make-direct-slot-definition |
---|
132 | (&rest properties |
---|
133 | &key name (initargs ()) (initform nil) (initfunction nil) |
---|
134 | (readers ()) (writers ()) (allocation :instance) |
---|
135 | &allow-other-keys) |
---|
136 | (let ((slot (copy-list properties))) ; Don't want to side effect &rest list |
---|
137 | (setf (getf* slot ':name) name) |
---|
138 | (setf (getf* slot ':initargs) initargs) |
---|
139 | (setf (getf* slot ':initform) initform) |
---|
140 | (setf (getf* slot ':initfunction) initfunction) |
---|
141 | (setf (getf* slot ':readers) readers) |
---|
142 | (setf (getf* slot ':writers) writers) |
---|
143 | (setf (getf* slot ':allocation) allocation) |
---|
144 | slot)) |
---|
145 | |
---|
146 | (defun make-effective-slot-definition |
---|
147 | (&rest properties |
---|
148 | &key name (initargs ()) (initform nil) (initfunction nil) |
---|
149 | (allocation :instance) |
---|
150 | &allow-other-keys) |
---|
151 | (let ((slot (copy-list properties))) ; Don't want to side effect &rest list |
---|
152 | (setf (getf* slot ':name) name) |
---|
153 | (setf (getf* slot ':initargs) initargs) |
---|
154 | (setf (getf* slot ':initform) initform) |
---|
155 | (setf (getf* slot ':initfunction) initfunction) |
---|
156 | (setf (getf* slot ':allocation) allocation) |
---|
157 | slot)) |
---|
158 | |
---|
159 | (defun slot-definition-name (slot) |
---|
160 | (getf slot ':name)) |
---|
161 | (defun (setf slot-definition-name) (new-value slot) |
---|
162 | (setf (getf* slot ':name) new-value)) |
---|
163 | |
---|
164 | (defun slot-definition-initfunction (slot) |
---|
165 | (getf slot ':initfunction)) |
---|
166 | (defun (setf slot-definition-initfunction) (new-value slot) |
---|
167 | (setf (getf* slot ':initfunction) new-value)) |
---|
168 | |
---|
169 | (defun slot-definition-initform (slot) |
---|
170 | (getf slot ':initform)) |
---|
171 | (defun (setf slot-definition-initform) (new-value slot) |
---|
172 | (setf (getf* slot ':initform) new-value)) |
---|
173 | |
---|
174 | (defun slot-definition-initargs (slot) |
---|
175 | (getf slot ':initargs)) |
---|
176 | (defun (setf slot-definition-initargs) (new-value slot) |
---|
177 | (setf (getf* slot ':initargs) new-value)) |
---|
178 | |
---|
179 | (defun slot-definition-readers (slot) |
---|
180 | (getf slot ':readers)) |
---|
181 | (defun (setf slot-definition-readers) (new-value slot) |
---|
182 | (setf (getf* slot ':readers) new-value)) |
---|
183 | |
---|
184 | (defun slot-definition-writers (slot) |
---|
185 | (getf slot ':writers)) |
---|
186 | (defun (setf slot-definition-writers) (new-value slot) |
---|
187 | (setf (getf* slot ':writers) new-value)) |
---|
188 | |
---|
189 | (defun slot-definition-allocation (slot) |
---|
190 | (getf slot ':allocation)) |
---|
191 | (defun (setf slot-definition-allocation) (new-value slot) |
---|
192 | (setf (getf* slot ':allocation) new-value)) |
---|
193 | |
---|
194 | ;;; finalize-inheritance |
---|
195 | |
---|
196 | (defun std-finalize-inheritance (class) |
---|
197 | (setf (class-precedence-list class) |
---|
198 | (funcall (if (eq (class-of class) the-class-standard-class) |
---|
199 | #'std-compute-class-precedence-list |
---|
200 | #'compute-class-precedence-list) |
---|
201 | class)) |
---|
202 | (setf (class-slots class) |
---|
203 | (funcall (if (eq (class-of class) the-class-standard-class) |
---|
204 | #'std-compute-slots |
---|
205 | #'compute-slots) |
---|
206 | class)) |
---|
207 | (values)) |
---|
208 | |
---|
209 | ;;; Class precedence lists |
---|
210 | |
---|
211 | (defun std-compute-class-precedence-list (class) |
---|
212 | (let ((classes-to-order (collect-superclasses* class))) |
---|
213 | (topological-sort classes-to-order |
---|
214 | (remove-duplicates |
---|
215 | (mapappend #'local-precedence-ordering |
---|
216 | classes-to-order)) |
---|
217 | #'std-tie-breaker-rule))) |
---|
218 | |
---|
219 | ;;; topological-sort implements the standard algorithm for topologically |
---|
220 | ;;; sorting an arbitrary set of elements while honoring the precedence |
---|
221 | ;;; constraints given by a set of (X,Y) pairs that indicate that element |
---|
222 | ;;; X must precede element Y. The tie-breaker procedure is called when it |
---|
223 | ;;; is necessary to choose from multiple minimal elements; both a list of |
---|
224 | ;;; candidates and the ordering so far are provided as arguments. |
---|
225 | |
---|
226 | (defun topological-sort (elements constraints tie-breaker) |
---|
227 | (let ((remaining-constraints constraints) |
---|
228 | (remaining-elements elements) |
---|
229 | (result ())) |
---|
230 | (loop |
---|
231 | (let ((minimal-elements |
---|
232 | (remove-if |
---|
233 | #'(lambda (class) |
---|
234 | (member class remaining-constraints |
---|
235 | :key #'cadr)) |
---|
236 | remaining-elements))) |
---|
237 | (when (null minimal-elements) |
---|
238 | (if (null remaining-elements) |
---|
239 | (return-from topological-sort result) |
---|
240 | (error "Inconsistent precedence graph."))) |
---|
241 | (let ((choice (if (null (cdr minimal-elements)) |
---|
242 | (car minimal-elements) |
---|
243 | (funcall tie-breaker |
---|
244 | minimal-elements |
---|
245 | result)))) |
---|
246 | (setq result (append result (list choice))) |
---|
247 | (setq remaining-elements |
---|
248 | (remove choice remaining-elements)) |
---|
249 | (setq remaining-constraints |
---|
250 | (remove choice |
---|
251 | remaining-constraints |
---|
252 | :test #'member))))))) |
---|
253 | |
---|
254 | ;;; In the event of a tie while topologically sorting class precedence lists, |
---|
255 | ;;; the CLOS Specification says to "select the one that has a direct subclass |
---|
256 | ;;; rightmost in the class precedence list computed so far." The same result |
---|
257 | ;;; is obtained by inspecting the partially constructed class precedence list |
---|
258 | ;;; from right to left, looking for the first minimal element to show up among |
---|
259 | ;;; the direct superclasses of the class precedence list constituent. |
---|
260 | ;;; (There's a lemma that shows that this rule yields a unique result.) |
---|
261 | |
---|
262 | (defun std-tie-breaker-rule (minimal-elements cpl-so-far) |
---|
263 | (dolist (cpl-constituent (reverse cpl-so-far)) |
---|
264 | (let* ((supers (class-direct-superclasses cpl-constituent)) |
---|
265 | (common (intersection minimal-elements supers))) |
---|
266 | (when (not (null common)) |
---|
267 | (return-from std-tie-breaker-rule (car common)))))) |
---|
268 | |
---|
269 | ;;; This version of collect-superclasses* isn't bothered by cycles in the class |
---|
270 | ;;; hierarchy, which sometimes happen by accident. |
---|
271 | |
---|
272 | (defun collect-superclasses* (class) |
---|
273 | (labels ((all-superclasses-loop (seen superclasses) |
---|
274 | (let ((to-be-processed |
---|
275 | (set-difference superclasses seen))) |
---|
276 | (if (null to-be-processed) |
---|
277 | superclasses |
---|
278 | (let ((class-to-process |
---|
279 | (car to-be-processed))) |
---|
280 | (all-superclasses-loop |
---|
281 | (cons class-to-process seen) |
---|
282 | (union (class-direct-superclasses |
---|
283 | class-to-process) |
---|
284 | superclasses))))))) |
---|
285 | (all-superclasses-loop () (list class)))) |
---|
286 | |
---|
287 | ;;; The local precedence ordering of a class C with direct superclasses C_1, |
---|
288 | ;;; C_2, ..., C_n is the set ((C C_1) (C_1 C_2) ...(C_n-1 C_n)). |
---|
289 | |
---|
290 | (defun local-precedence-ordering (class) |
---|
291 | (mapcar #'list |
---|
292 | (cons class |
---|
293 | (butlast (class-direct-superclasses class))) |
---|
294 | (class-direct-superclasses class))) |
---|
295 | |
---|
296 | ;;; Slot inheritance |
---|
297 | |
---|
298 | (defun std-compute-slots (class) |
---|
299 | (let* ((all-slots (mapappend #'class-direct-slots |
---|
300 | (class-precedence-list class))) |
---|
301 | (all-names (remove-duplicates |
---|
302 | (mapcar #'slot-definition-name all-slots)))) |
---|
303 | (mapcar #'(lambda (name) |
---|
304 | (funcall |
---|
305 | (if (eq (class-of class) the-class-standard-class) |
---|
306 | #'std-compute-effective-slot-definition |
---|
307 | #'compute-effective-slot-definition) |
---|
308 | class |
---|
309 | (remove name all-slots |
---|
310 | :key #'slot-definition-name |
---|
311 | :test-not #'eq))) |
---|
312 | all-names))) |
---|
313 | |
---|
314 | (defun std-compute-effective-slot-definition (class direct-slots) |
---|
315 | (declare (ignore class)) |
---|
316 | (let ((initer (find-if-not #'null direct-slots |
---|
317 | :key #'slot-definition-initfunction))) |
---|
318 | (make-effective-slot-definition |
---|
319 | :name (slot-definition-name (car direct-slots)) |
---|
320 | :initform (if initer |
---|
321 | (slot-definition-initform initer) |
---|
322 | nil) |
---|
323 | :initfunction (if initer |
---|
324 | (slot-definition-initfunction initer) |
---|
325 | nil) |
---|
326 | :initargs (remove-duplicates |
---|
327 | (mapappend #'slot-definition-initargs |
---|
328 | direct-slots)) |
---|
329 | :allocation (slot-definition-allocation (car direct-slots))))) |
---|
330 | |
---|
331 | ;;; Simple vectors are used for slot storage. |
---|
332 | |
---|
333 | (defun allocate-slot-storage (size initial-value) |
---|
334 | (make-array size :initial-element initial-value)) |
---|
335 | |
---|
336 | ;;; Standard instance allocation |
---|
337 | |
---|
338 | (defvar the-class-standard-class (find-class 'standard-class)) |
---|
339 | |
---|
340 | (defparameter secret-unbound-value (list "slot unbound")) |
---|
341 | |
---|
342 | (defun instance-slot-p (slot) |
---|
343 | (eq (slot-definition-allocation slot) ':instance)) |
---|
344 | |
---|
345 | (defun std-allocate-instance (class) |
---|
346 | (allocate-std-instance |
---|
347 | class |
---|
348 | (allocate-slot-storage (count-if #'instance-slot-p (class-slots class)) |
---|
349 | secret-unbound-value))) |
---|
350 | |
---|
351 | (defun allocate-instance (class) |
---|
352 | (std-allocate-instance class)) |
---|
353 | |
---|
354 | (defun make-instance-standard-class (metaclass &key name direct-superclasses direct-slots |
---|
355 | &allow-other-keys) |
---|
356 | (declare (ignore metaclass)) |
---|
357 | ;; (format t "name = ~S~%" name) |
---|
358 | ;; (format t "direct-superclasses = ~S~%" direct-superclasses) |
---|
359 | ;; (format t "direct-slots = ~S~%" direct-slots) |
---|
360 | (let ((class (std-allocate-instance (find-class 'standard-class)))) |
---|
361 | (setf (class-name class) name) |
---|
362 | (setf (class-direct-subclasses class) ()) |
---|
363 | (setf (class-direct-methods class) ()) |
---|
364 | (std-after-initialization-for-classes class |
---|
365 | :direct-slots direct-slots |
---|
366 | :direct-superclasses direct-superclasses) |
---|
367 | class)) |
---|
368 | |
---|
369 | ;; FIXME |
---|
370 | (defun std-after-initialization-for-classes (class |
---|
371 | &key direct-superclasses direct-slots |
---|
372 | &allow-other-keys) |
---|
373 | (let ((supers |
---|
374 | (or direct-superclasses |
---|
375 | (list (find-class 'standard-object))))) |
---|
376 | (setf (class-direct-superclasses class) supers) |
---|
377 | (dolist (superclass supers) |
---|
378 | (push class (class-direct-subclasses superclass)))) |
---|
379 | (let ((slots |
---|
380 | (mapcar #'(lambda (slot-properties) |
---|
381 | (apply #'make-direct-slot-definition |
---|
382 | slot-properties)) |
---|
383 | direct-slots))) |
---|
384 | (setf (class-direct-slots class) slots) |
---|
385 | ;; (dolist (direct-slot slots) |
---|
386 | ;; (dolist (reader (slot-definition-readers direct-slot)) |
---|
387 | ;; (add-reader-method |
---|
388 | ;; class reader (slot-definition-name direct-slot))) |
---|
389 | ;; (dolist (writer (slot-definition-writers direct-slot)) |
---|
390 | ;; (add-writer-method |
---|
391 | ;; class writer (slot-definition-name direct-slot)))) |
---|
392 | ) |
---|
393 | (funcall (if (eq (class-of class) (find-class 'standard-class)) |
---|
394 | #'std-finalize-inheritance |
---|
395 | #'finalize-inheritance) |
---|
396 | class) |
---|
397 | (values)) |
---|
398 | |
---|
399 | (defun ensure-class (name &rest all-keys &allow-other-keys) |
---|
400 | (let ((class (find-class name nil))) |
---|
401 | (unless class |
---|
402 | (setf class (apply #'make-instance-standard-class (find-class 'standard-class) :name name all-keys)) |
---|
403 | (add-class class)) |
---|
404 | class)) |
---|
405 | |
---|
406 | (defmacro defclass (name direct-superclasses direct-slots |
---|
407 | &rest options) |
---|
408 | `(ensure-class ',name |
---|
409 | :direct-superclasses |
---|
410 | ,(canonicalize-direct-superclasses direct-superclasses) |
---|
411 | :direct-slots |
---|
412 | ,(canonicalize-direct-slots direct-slots) |
---|
413 | ,@(canonicalize-defclass-options options))) |
---|