/[cmucl]/src/pcl/std-class.lisp
ViewVC logotype

Contents of /src/pcl/std-class.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.73 - (hide annotations)
Fri Jul 9 22:00:30 2004 UTC (9 years, 9 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2004-08, snapshot-2004-09, prm-before-macosx-merge-tag
Changes since 1.72: +5 -2 lines
Initialization of condition class metaobjects no longer creates an
instance of the condition.  (Bug reported on sbcl-help.  Fix stolen
from sbcl.)
1 wlott 1.1 ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
2     ;;;
3     ;;; *************************************************************************
4     ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5     ;;; All rights reserved.
6     ;;;
7     ;;; Use and copying of this software and preparation of derivative works
8     ;;; based upon this software are permitted. Any distribution of this
9     ;;; software or derivative works must comply with all applicable United
10     ;;; States export control laws.
11     ;;;
12     ;;; This software is made available AS IS, and Xerox Corporation makes no
13     ;;; warranty about the software, its performance or its conformity to any
14     ;;; specification.
15     ;;;
16     ;;; Any person obtaining a copy of this software is requested to send their
17     ;;; name and post office or electronic mail address to:
18     ;;; CommonLoops Coordinator
19     ;;; Xerox PARC
20     ;;; 3333 Coyote Hill Rd.
21     ;;; Palo Alto, CA 94304
22     ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23     ;;;
24     ;;; Suggestions, comments and requests for improvements are also welcome.
25     ;;; *************************************************************************
26     ;;;
27 pw 1.25
28 gerd 1.61 (file-comment
29 rtoy 1.73 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/std-class.lisp,v 1.73 2004/07/09 22:00:30 rtoy Exp $")
30 wlott 1.1
31 phg 1.7 (in-package :pcl)
32 wlott 1.1
33 ram 1.4 (defmethod slot-accessor-function ((slotd effective-slot-definition) type)
34     (ecase type
35     (reader (slot-definition-reader-function slotd))
36     (writer (slot-definition-writer-function slotd))
37     (boundp (slot-definition-boundp-function slotd))))
38 wlott 1.1
39 ram 1.6 (defmethod (setf slot-accessor-function) (function
40     (slotd effective-slot-definition) type)
41 ram 1.4 (ecase type
42 ram 1.6 (reader (setf (slot-definition-reader-function slotd) function))
43     (writer (setf (slot-definition-writer-function slotd) function))
44 ram 1.4 (boundp (setf (slot-definition-boundp-function slotd) function))))
45    
46     (defconstant *slotd-reader-function-std-p* 1)
47     (defconstant *slotd-writer-function-std-p* 2)
48     (defconstant *slotd-boundp-function-std-p* 4)
49 ram 1.6 (defconstant *slotd-all-function-std-p* 7)
50 ram 1.4
51     (defmethod slot-accessor-std-p ((slotd effective-slot-definition) type)
52     (let ((flags (slot-value slotd 'accessor-flags)))
53 ram 1.6 (declare (type fixnum flags))
54 ram 1.4 (if (eq type 'all)
55 ram 1.6 (eql *slotd-all-function-std-p* flags)
56 ram 1.4 (let ((mask (ecase type
57     (reader *slotd-reader-function-std-p*)
58     (writer *slotd-writer-function-std-p*)
59     (boundp *slotd-boundp-function-std-p*))))
60 ram 1.6 (declare (type fixnum mask))
61     (not (zerop (the fixnum (logand mask flags))))))))
62 ram 1.4
63     (defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type)
64     (let ((mask (ecase type
65     (reader *slotd-reader-function-std-p*)
66     (writer *slotd-writer-function-std-p*)
67     (boundp *slotd-boundp-function-std-p*)))
68     (flags (slot-value slotd 'accessor-flags)))
69 ram 1.6 (declare (type fixnum mask flags))
70 ram 1.4 (setf (slot-value slotd 'accessor-flags)
71     (if value
72 ram 1.6 (the fixnum (logior mask flags))
73     (the fixnum (logand (the fixnum (lognot mask)) flags)))))
74 ram 1.4 value)
75    
76     (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition))
77     (let* ((name (slot-value slotd 'name))
78 ram 1.6 (class (slot-value slotd 'class)))
79 gerd 1.65 (setf (gethash class (slot-name->class-table name)) slotd)
80 ram 1.4 (dolist (type '(reader writer boundp))
81 ram 1.6 (let* ((gf-name (ecase type
82     (reader 'slot-value-using-class)
83     (writer '(setf slot-value-using-class))
84     (boundp 'slot-boundp-using-class)))
85     (gf (gdefinition gf-name)))
86     (compute-slot-accessor-info slotd type gf)))
87     (initialize-internal-slot-gfs name)))
88 ram 1.4
89 gerd 1.54 ;;;
90     ;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF
91     ;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/
92     ;;; writing/testing effective slot SLOTD.
93     ;;;
94     ;;; TYPE is one of the symbols READER, WRITER or BOUNDP, depending on
95     ;;; GF. Store the effective method in the effective slot definition
96     ;;; object itself; these GFs have special dispatch functions calling
97     ;;; effective methods directly retrieved from effective slot
98     ;;; definition objects, as an optimization.
99     ;;;
100     ;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION,
101     ;;; or some such.
102     ;;;
103 gerd 1.44 (defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
104     type gf)
105 ram 1.6 (let* ((name (slot-value slotd 'name))
106     (class (slot-value slotd 'class))
107     (old-slotd (find-slot-definition class name))
108     (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
109     (multiple-value-bind (function std-p)
110     (if (eq *boot-state* 'complete)
111     (get-accessor-method-function gf type class slotd)
112     (get-optimized-std-accessor-method-function class slotd type))
113     (setf (slot-accessor-std-p slotd type) std-p)
114     (setf (slot-accessor-function slotd type) function))
115 gerd 1.44 (when (and old-slotd
116     (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
117     (record-pv-update-info slotd))))
118 ram 1.5
119 ram 1.6 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
120     :instance)
121 ram 1.5
122 ram 1.6
123 ram 1.5
124 ram 1.6 (defmethod shared-initialize :after ((object documentation-mixin)
125     slot-names
126     &key (documentation nil documentation-p))
127     (declare (ignore slot-names))
128     (when documentation-p
129 gerd 1.43 (setf (documentation object nil) documentation)))
130 ram 1.5
131 dtc 1.11 (defmethod documentation (object doc-type)
132 dtc 1.10 (declare (ignore object doc-type))
133     nil)
134 wlott 1.1
135 dtc 1.11 (defmethod (setf documentation) (new-value object doc-type)
136 wlott 1.1 (declare (ignore new-value doc-type))
137 gerd 1.44 (error "~@<Can't change the documentation of ~S.~@:>" object))
138 wlott 1.1
139 dtc 1.11 (defmethod documentation ((object documentation-mixin) doc-type)
140 ram 1.6 (declare (ignore doc-type))
141     (plist-value object 'documentation))
142 wlott 1.1
143 dtc 1.11 (defmethod (setf documentation) (new-value (object documentation-mixin) doc-type)
144 ram 1.6 (declare (ignore doc-type))
145     (setf (plist-value object 'documentation) new-value))
146 wlott 1.1
147 dtc 1.11 (defmethod documentation ((slotd standard-slot-definition) doc-type)
148 ram 1.6 (declare (ignore doc-type))
149     (slot-value slotd 'documentation))
150 wlott 1.1
151 dtc 1.11 (defmethod (setf documentation) (new-value (slotd standard-slot-definition) doc-type)
152 ram 1.6 (declare (ignore doc-type))
153     (setf (slot-value slotd 'documentation) new-value))
154 gerd 1.43
155     (defmethod (setf documentation) (doc (gf generic-function) type)
156     (declare (ignore type))
157 gerd 1.61 (setf (info function documentation (generic-function-name gf))
158 gerd 1.43 doc))
159 wlott 1.1
160    
161     ;;;
162     ;;; Various class accessors that are a little more complicated than can be
163     ;;; done with automatically generated reader methods.
164     ;;;
165     (defmethod class-prototype ((class std-class))
166     (with-slots (prototype) class
167 ram 1.6 (or prototype (setq prototype (allocate-instance class)))))
168 wlott 1.1
169 ram 1.6 (defmethod class-prototype ((class structure-class))
170     (with-slots (prototype wrapper defstruct-constructor) class
171     (or prototype
172     (setq prototype
173 pw 1.23 (if defstruct-constructor
174 ram 1.6 (allocate-instance class)
175     (allocate-standard-instance wrapper))))))
176 ram 1.4
177 rtoy 1.73 (defmethod class-prototype ((class condition-class))
178     (with-slots (prototype) class
179     (or prototype (setf prototype (allocate-instance class)))))
180    
181 ram 1.6 (defmethod class-direct-default-initargs ((class slot-class))
182     (plist-value class 'direct-default-initargs))
183    
184     (defmethod class-default-initargs ((class slot-class))
185     (plist-value class 'default-initargs))
186    
187 ram 1.4 (defmethod class-constructors ((class slot-class))
188 wlott 1.1 (plist-value class 'constructors))
189    
190     (defmethod class-slot-cells ((class std-class))
191     (plist-value class 'class-slot-cells))
192    
193    
194     ;;;
195     ;;; Class accessors that are even a little bit more complicated than those
196     ;;; above. These have a protocol for updating them, we must implement that
197     ;;; protocol.
198     ;;;
199    
200     ;;;
201     ;;; Maintaining the direct subclasses backpointers. The update methods are
202     ;;; here, the values are read by an automatically generated reader method.
203     ;;;
204     (defmethod add-direct-subclass ((class class) (subclass class))
205 gerd 1.44 (check-seals class 'add-direct-subclass)
206 wlott 1.1 (with-slots (direct-subclasses) class
207     (pushnew subclass direct-subclasses)
208     subclass))
209    
210     (defmethod remove-direct-subclass ((class class) (subclass class))
211 gerd 1.44 (check-seals class 'remove-direct-subclass)
212 wlott 1.1 (with-slots (direct-subclasses) class
213     (setq direct-subclasses (remove subclass direct-subclasses))
214     subclass))
215    
216     ;;;
217     ;;; Maintaining the direct-methods and direct-generic-functions backpointers.
218     ;;;
219     ;;; There are four generic functions involved, each has one method for the
220     ;;; class case and another method for the damned EQL specializers. All of
221     ;;; these are specified methods and appear in their specified place in the
222     ;;; class graph.
223     ;;;
224 ram 1.4 ;;; ADD-DIRECT-METHOD
225     ;;; REMOVE-DIRECT-METHOD
226     ;;; SPECIALIZER-DIRECT-METHODS
227     ;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
228 wlott 1.1 ;;;
229     ;;; In each case, we maintain one value which is a cons. The car is the list
230     ;;; methods. The cdr is a list of the generic functions. The cdr is always
231     ;;; computed lazily.
232     ;;;
233    
234 ram 1.4 (defmethod add-direct-method ((specializer class) (method method))
235 wlott 1.1 (with-slots (direct-methods) specializer
236     (setf (car direct-methods) (adjoin method (car direct-methods)) ;PUSH
237     (cdr direct-methods) ()))
238     method)
239    
240 ram 1.4 (defmethod remove-direct-method ((specializer class) (method method))
241 wlott 1.1 (with-slots (direct-methods) specializer
242     (setf (car direct-methods) (remove method (car direct-methods))
243     (cdr direct-methods) ()))
244 gerd 1.44 (remove-inline-access-method specializer method)
245 wlott 1.1 method)
246    
247 ram 1.4 (defmethod specializer-direct-methods ((specializer class))
248 wlott 1.1 (with-slots (direct-methods) specializer
249     (car direct-methods)))
250    
251 ram 1.4 (defmethod specializer-direct-generic-functions ((specializer class))
252 wlott 1.1 (with-slots (direct-methods) specializer
253     (or (cdr direct-methods)
254     (setf (cdr direct-methods)
255 pmai 1.32 (loop for method in (car direct-methods)
256     for generic-function = (method-generic-function method)
257     unless (member generic-function collected :test #'eq)
258     collect generic-function into collected
259     finally (return collected))))))
260 wlott 1.1
261    
262     ;;;
263     ;;; This hash table is used to store the direct methods and direct generic
264     ;;; functions of EQL specializers. Each value in the table is the cons.
265     ;;;
266 gerd 1.44 (defvar *eql-specializer-methods* (make-hash-table :test 'eql))
267     (defvar *class-eq-specializer-methods* (make-hash-table :test 'eq))
268 wlott 1.1
269 ram 1.4 (defmethod specializer-method-table ((specializer eql-specializer))
270     *eql-specializer-methods*)
271    
272     (defmethod specializer-method-table ((specializer class-eq-specializer))
273     *class-eq-specializer-methods*)
274    
275     (defmethod add-direct-method ((specializer specializer-with-object) (method method))
276 ram 1.2 (let* ((object (specializer-object specializer))
277 ram 1.4 (table (specializer-method-table specializer))
278     (entry (gethash object table)))
279 wlott 1.1 (unless entry
280     (setq entry
281 ram 1.4 (setf (gethash object table)
282 wlott 1.1 (cons nil nil))))
283     (setf (car entry) (adjoin method (car entry))
284     (cdr entry) ())
285     method))
286    
287 ram 1.4 (defmethod remove-direct-method ((specializer specializer-with-object) (method method))
288 ram 1.2 (let* ((object (specializer-object specializer))
289 ram 1.4 (entry (gethash object (specializer-method-table specializer))))
290 wlott 1.1 (when entry
291     (setf (car entry) (remove method (car entry))
292     (cdr entry) ()))
293     method))
294    
295 ram 1.4 (defmethod specializer-direct-methods ((specializer specializer-with-object))
296     (car (gethash (specializer-object specializer)
297     (specializer-method-table specializer))))
298 wlott 1.1
299 ram 1.4 (defmethod specializer-direct-generic-functions ((specializer specializer-with-object))
300 ram 1.2 (let* ((object (specializer-object specializer))
301 ram 1.4 (entry (gethash object (specializer-method-table specializer))))
302 wlott 1.1 (when entry
303     (or (cdr entry)
304     (setf (cdr entry)
305 pmai 1.32 (loop for method in (car entry)
306     for generic-function = (method-generic-function method)
307     unless (member generic-function collected :test #'eq)
308     collect generic-function into collected
309     finally (return collected)))))))
310 wlott 1.1
311 ram 1.4 (defun map-specializers (function)
312 pmai 1.32 (map-all-classes (lambda (class)
313     (funcall function (class-eq-specializer class))
314     (funcall function class)))
315     (maphash (lambda (object methods)
316     (declare (ignore methods))
317     (intern-eql-specializer object))
318 ram 1.4 *eql-specializer-methods*)
319 pmai 1.32 (maphash (lambda (object specl)
320     (declare (ignore object))
321     (funcall function specl))
322 ram 1.4 *eql-specializer-table*)
323     nil)
324    
325 gerd 1.44 (defun map-all-classes (function &optional (root t))
326     (let ((braid-p (memq *boot-state* '(braid complete)))
327     (root (if (symbolp root) (find-class root) root)))
328     (labels ((map-class (class)
329     (mapc #'map-class
330     (if braid-p
331     (class-direct-subclasses class)
332     (early-class-direct-subclasses class)))
333     (funcall function class)))
334     (map-class root))))
335    
336 ram 1.4 (defun map-all-generic-functions (function)
337     (let ((all-generic-functions (make-hash-table :test 'eq)))
338 pmai 1.32 (map-specializers (lambda (specl)
339     (dolist (gf (specializer-direct-generic-functions specl))
340     (unless (gethash gf all-generic-functions)
341     (setf (gethash gf all-generic-functions) t)
342     (funcall function gf))))))
343 ram 1.4 nil)
344    
345     (defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key)
346     (declare (ignore slot-names))
347     (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
348    
349     (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
350     (declare (ignore slot-names))
351     (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
352    
353 wlott 1.1
354    
355 dtc 1.24 (defun real-load-defclass (name metaclass-name supers slots other)
356 gerd 1.44 (apply #'ensure-class name :metaclass metaclass-name
357     :direct-superclasses supers
358     :direct-slots slots
359     other))
360 wlott 1.1
361 phg 1.7 (setf (gdefinition 'load-defclass) #'real-load-defclass)
362 ram 1.6
363 gerd 1.69 ;;;
364     ;;; The DEFCLASS spec says that this redefines a class with proper
365     ;;; name NAME, where S is the proper name of class C if S =
366     ;;; (CLASS-NAME C) and (FIND-CLASS S) = C.
367     ;;;
368 ram 1.6 (defun ensure-class (name &rest all)
369 gerd 1.69 (let ((class (find-class name nil)))
370     (when (and class (neq name (class-name class)))
371     (setq class nil))
372     (apply #'ensure-class-using-class class name all)))
373 ram 1.6
374 gerd 1.47 (defmethod ensure-class-using-class ((class null) name &rest args &key)
375 ram 1.6 (multiple-value-bind (meta initargs)
376     (ensure-class-values class args)
377 gerd 1.44 (inform-type-system-about-class (class-prototype meta) name)
378 gerd 1.71 (let ((class (apply #'make-instance meta :name name initargs)))
379     (setf (find-class name) class)
380     (inform-type-system-about-class class name)
381     class)))
382 ram 1.6
383 gerd 1.47 (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
384 ram 1.6 (multiple-value-bind (meta initargs)
385     (ensure-class-values class args)
386 gerd 1.44 (unless (eq (class-of class) meta)
387 gerd 1.49 (apply #'change-class class meta initargs))
388 ram 1.6 (apply #'reinitialize-instance class initargs)
389 phg 1.7 (setf (find-class name) class)
390 gerd 1.44 (inform-type-system-about-class class name)
391 ram 1.6 class))
392    
393 phg 1.7 (defmethod class-predicate-name ((class t))
394     'function-returning-nil)
395    
396 wlott 1.1 (defun ensure-class-values (class args)
397     (let* ((initargs (copy-list args))
398     (unsupplied (list 1))
399     (supplied-meta (getf initargs :metaclass unsupplied))
400     (supplied-supers (getf initargs :direct-superclasses unsupplied))
401 gerd 1.44 (meta (cond ((neq supplied-meta unsupplied)
402     (find-class supplied-meta))
403     ((or (null class)
404     (forward-referenced-class-p class))
405     *the-class-standard-class*)
406     (t
407     (class-of class)))))
408 gerd 1.50 (flet ((fix-super (super)
409     (cond ((classp super)
410     super)
411     ((legal-class-name-p super)
412     (or (find-class super nil)
413     (make-instance 'forward-referenced-class
414     :name super)))
415     (t
416 pmai 1.33 (simple-program-error
417 gerd 1.50 "~@<~S is not a class or a legal class name.~@:>"
418     super)))))
419 pmai 1.31 ;;
420     ;; CLHS: signal PROGRAM-ERROR, if
421     ;; (a) there are any duplicate slot names
422     ;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or
423     ;; :DOCUMENTATION appears more than one in a single slot description.
424     (loop for (slot . more) on (getf initargs :direct-slots)
425     for slot-name = (getf slot :name)
426     if (some (lambda (s) (eq slot-name (getf s :name))) more) do
427 pmai 1.33 (simple-program-error
428 gerd 1.44 "~@<More than one direct slot with name ~S.~@:>"
429 pmai 1.33 slot-name)
430 pmai 1.31 else do
431     (loop for (option value . more) on slot by #'cddr
432 gerd 1.44 if (and (member option '(:allocation :type :initform
433     :documentation))
434     (not (eq unsupplied
435     (getf more option unsupplied)))) do
436     (simple-program-error
437     "~@<Duplicate slot option ~S for slot ~S.~@:>"
438     option slot-name)
439     else if (and (eq option :readers)
440     (notevery #'symbolp value)) do
441     (simple-program-error
442     "~@<Slot ~S: slot reader names must be symbols.~@:>"
443     slot-name)
444     else if (and (eq option :initargs)
445     (notevery #'symbolp value)) do
446 pmai 1.33 (simple-program-error
447 gerd 1.44 "~@<Slot ~S: initarg names must be symbols.~@:>"
448     slot-name)))
449 pmai 1.31 ;;
450     ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name
451     ;; appears more than once in :DEFAULT-INITARGS class option.
452     (loop for (initarg . more) on (getf initargs :direct-default-initargs)
453     for name = (car initarg)
454     when (some (lambda (a) (eq (car a) name)) more) do
455 pmai 1.33 (simple-program-error
456 gerd 1.44 "~@<Duplicate initialization argument ~
457     name ~S in ~s of class ~A.~@:>"
458     name :default-initargs class))
459     ;;
460     (loop for (arg value) on initargs by #'cddr
461     count (eq arg :metaclass) into metaclass
462     count (eq arg :direct-default-initargs) into default-initargs
463     when (or (> metaclass 1) (> default-initargs 1)) do
464     (simple-program-error
465     "~@<Class ~S: More than one ~S specified~@:>"
466     class (if (eq arg :direct-default-initargs)
467     :default-initargs arg)))
468     (remf initargs :metaclass)
469     (remf initargs :direct-superclasses)
470 pmai 1.31 ;;
471 wlott 1.1 (values meta
472 gerd 1.44 (nconc (when (neq supplied-supers unsupplied)
473     (list :direct-superclasses
474     (mapcar #'fix-super supplied-supers)))
475     initargs)))))
476 wlott 1.1
477    
478     ;;;
479     ;;;
480     ;;;
481     (defmethod shared-initialize :after
482     ((class std-class)
483     slot-names
484 ram 1.2 &key (direct-superclasses nil direct-superclasses-p)
485     (direct-slots nil direct-slots-p)
486 ram 1.4 (direct-default-initargs nil direct-default-initargs-p)
487     (predicate-name nil predicate-name-p))
488 wlott 1.1 (declare (ignore slot-names))
489 pmai 1.28 (cond ((or direct-superclasses-p
490     (null (slot-value class 'direct-superclasses)))
491 dtc 1.17 (setq direct-superclasses
492     (or direct-superclasses
493     (list (if (funcallable-standard-class-p class)
494     *the-class-funcallable-standard-object*
495     *the-class-standard-object*))))
496     (dolist (superclass direct-superclasses)
497     (unless (validate-superclass class superclass)
498 gerd 1.44 (error "~@<The class ~S was specified as a ~
499     super-class of the class ~S, ~
500     but the meta-classes ~S and ~S are incompatible. ~
501     Define a method for ~S to avoid this error.~@:>"
502 dtc 1.17 superclass class (class-of superclass) (class-of class)
503     'validate-superclass)))
504     (setf (slot-value class 'direct-superclasses) direct-superclasses))
505     (t
506     (setq direct-superclasses (slot-value class 'direct-superclasses))))
507 ram 1.2 (setq direct-slots
508     (if direct-slots-p
509     (setf (slot-value class 'direct-slots)
510 gerd 1.50 (mapcar (lambda (pl) (make-direct-slotd class pl))
511     direct-slots))
512 ram 1.2 (slot-value class 'direct-slots)))
513     (if direct-default-initargs-p
514 gerd 1.50 (setf (plist-value class 'direct-default-initargs)
515     direct-default-initargs)
516     (setq direct-default-initargs
517     (plist-value class 'direct-default-initargs)))
518 gerd 1.56 ;;
519     ;; Initialize shared slots. A class may inherit initforms for
520     ;; shared slots from superclasses. Such initializations are
521     ;; done in UPDATE-CLASS-SLOT-VALUES.
522 gerd 1.61 (collect ((cells))
523 gerd 1.56 (dolist (dslotd direct-slots)
524     (when (eq (slot-definition-allocation dslotd) :class)
525     (let ((initfn (slot-definition-initfunction dslotd)))
526     (cells (cons (slot-definition-name dslotd)
527     (if initfn
528     (funcall initfn)
529     +slot-unbound+))))))
530     (setf (plist-value class 'class-slot-cells) (cells)))
531     ;;
532 ram 1.6 (setq predicate-name (if predicate-name-p
533     (setf (slot-value class 'predicate-name)
534     (car predicate-name))
535     (or (slot-value class 'predicate-name)
536     (setf (slot-value class 'predicate-name)
537     (make-class-predicate-name (class-name class))))))
538 wlott 1.1 (add-direct-subclasses class direct-superclasses)
539 gerd 1.47 (make-class-predicate class predicate-name)
540 ram 1.6 (update-class class nil)
541 gerd 1.50 (add-slot-accessors class direct-slots)
542     (make-preliminary-layout class))
543    
544     (defmethod shared-initialize :after ((class forward-referenced-class)
545     slot-names &key &allow-other-keys)
546     (declare (ignore slot-names))
547     (make-preliminary-layout class))
548    
549     ;;;
550     ;;; Give CLASS a preliminary layout, if it doesn't have a layout
551     ;;; already. This is done to make CLASS known to the type system
552     ;;; before the class is finalized, and is a consequence of the class
553     ;;; schizophrenia we are suffering from.
554     ;;;
555     (defvar *allow-forward-referenced-classes-in-cpl-p* nil)
556    
557     (defun make-preliminary-layout (class)
558     (flet ((compute-preliminary-cpl (root)
559     (let ((*allow-forward-referenced-classes-in-cpl-p* t))
560     (compute-class-precedence-list root))))
561     (unless (class-finalized-p class)
562     (let ((name (class-name class)))
563     (setf (find-class name) class)
564     (inform-type-system-about-class class name)
565     (let ((layout (make-wrapper 0 class))
566     (kernel-class (kernel::find-class name)))
567     (setf (kernel:layout-class layout) kernel-class)
568     (setf (kernel:%class-pcl-class kernel-class) class)
569     (setf (slot-value class 'wrapper) layout)
570     (let ((cpl (compute-preliminary-cpl class)))
571     (setf (kernel:layout-inherits layout)
572     (kernel:order-layout-inherits
573     (map 'simple-vector #'class-wrapper
574     (reverse (rest cpl))))))
575     (kernel:register-layout layout :invalidate t)
576 gerd 1.53 (setf (kernel:%class-layout kernel-class) layout)
577     (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))
578 wlott 1.1
579 ram 1.6 (defmethod shared-initialize :before ((class class) slot-names &key name)
580     (declare (ignore slot-names name))
581 ram 1.4 (setf (slot-value class 'type) `(class ,class))
582     (setf (slot-value class 'class-eq-specializer)
583     (make-instance 'class-eq-specializer :class class)))
584    
585 pw 1.22 (defmethod reinitialize-instance :before ((class slot-class)
586     &key direct-superclasses)
587     (remove-direct-subclasses class direct-superclasses)
588 wlott 1.1 (remove-slot-accessors class (class-direct-slots class)))
589    
590 ram 1.6 (defmethod reinitialize-instance :after ((class slot-class)
591 wlott 1.1 &rest initargs
592     &key)
593     (map-dependents class
594 pmai 1.32 (lambda (dependent)
595     (apply #'update-dependent class dependent initargs))))
596 ram 1.4
597 ram 1.6 (defmethod shared-initialize :after
598     ((class structure-class)
599     slot-names
600     &key (direct-superclasses nil direct-superclasses-p)
601     (direct-slots nil direct-slots-p)
602     direct-default-initargs
603     (predicate-name nil predicate-name-p))
604     (declare (ignore slot-names direct-default-initargs))
605     (if direct-superclasses-p
606     (setf (slot-value class 'direct-superclasses)
607     (or direct-superclasses
608     (setq direct-superclasses
609     (and (not (eq (class-name class) 'structure-object))
610     (list *the-class-structure-object*)))))
611     (setq direct-superclasses (slot-value class 'direct-superclasses)))
612     (let* ((name (class-name class))
613     (from-defclass-p (slot-value class 'from-defclass-p))
614     (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
615     (if direct-slots-p
616     (setf (slot-value class 'direct-slots)
617     (setq direct-slots
618 pmai 1.32 (mapcar (lambda (pl)
619     (when defstruct-p
620     (let* ((slot-name (getf pl :name))
621 gerd 1.44 (accessor
622 gerd 1.61 (symbolicate*
623 gerd 1.44 *package*
624     (if (symbol-package name)
625     (package-name (symbol-package name))
626     "")
627     "::" name " structure class " slot-name)))
628 pmai 1.32 (setq pl (list* :defstruct-accessor-symbol accessor
629     pl))))
630     (make-direct-slotd class pl))
631 ram 1.6 direct-slots)))
632     (setq direct-slots (slot-value class 'direct-slots)))
633 gerd 1.58 (if defstruct-p
634     (let* ((include (car (slot-value class 'direct-superclasses)))
635 gerd 1.61 (conc-name (symbolicate* *package*
636     (if (symbol-package name)
637     (package-name (symbol-package name))
638     "")
639     "::" name " structure class "))
640 gerd 1.58 ;;
641     ;; It's not possible to use a generalized name for the
642     ;; constructor function. It shouldn't matter though, I think,
643     ;; like for the slot names above, because this stuff is not
644     ;; supposed to be used by users directly.
645     (constructor
646 gerd 1.61 (symbolicate* *package* conc-name " constructor"))
647 gerd 1.58 (defstruct `(defstruct (,name
648     ,@(when include
649     `((:include ,(class-name include))))
650     (:predicate nil)
651     (:conc-name ,conc-name)
652     (:constructor ,constructor ()))
653     ;;
654     ;; Use a temporary unbound marker that lets
655     ;; SHARED-INITIALIZE recognize if a before-method
656     ;; has written to a slot.
657     ,@(mapcar (lambda (slot)
658     `(,(slot-definition-name slot)
659     '.unbound.))
660     direct-slots)))
661     (reader-names (mapcar (lambda (slotd)
662     (list 'slot-accessor name
663     (slot-definition-name slotd)
664     'reader))
665     direct-slots))
666     (writer-names (mapcar (lambda (slotd)
667     (list 'slot-accessor name
668     (slot-definition-name slotd)
669     'writer))
670     direct-slots))
671     (readers-init
672     (mapcar (lambda (slotd reader-name)
673     (let ((accessor
674     (slot-definition-defstruct-accessor-symbol slotd)))
675     `(defun ,reader-name (obj)
676     (declare (type ,name obj))
677     (,accessor obj))))
678     direct-slots reader-names))
679     (writers-init
680     (mapcar (lambda (slotd writer-name)
681     (let ((accessor
682     (slot-definition-defstruct-accessor-symbol slotd)))
683     `(defun ,writer-name (nv obj)
684     (declare (type ,name obj))
685     (setf (,accessor obj) nv))))
686     direct-slots writer-names))
687     (defstruct-form
688     `(progn
689     ,defstruct
690     ,@readers-init ,@writers-init)))
691     (unless (structure-type-p name) (eval defstruct-form))
692     (mapc (lambda (dslotd reader-name writer-name)
693     (let* ((reader (when (fboundp reader-name)
694     (gdefinition reader-name)))
695     (writer (when (fboundp writer-name)
696     (gdefinition writer-name))))
697     (setf (slot-value dslotd 'internal-reader-function) reader)
698     (setf (slot-value dslotd 'internal-writer-function) writer)))
699     direct-slots reader-names writer-names)
700     (setf (slot-value class 'defstruct-form) defstruct-form)
701     (setf (slot-value class 'defstruct-constructor) constructor))
702     ;;
703     ;; ALLOCATE-INSTANCE is supposed to work with structures
704     ;; defined with DEFSTRUCT.
705     (with-slots (defstruct-constructor) class
706     (setq defstruct-constructor
707     (make-defstruct-allocation-function class)))))
708     ;;
709 ram 1.6 (add-direct-subclasses class direct-superclasses)
710     (setf (slot-value class 'class-precedence-list)
711     (compute-class-precedence-list class))
712     (setf (slot-value class 'slots) (compute-slots class))
713 gerd 1.44 (let ((lclass (kernel::find-class (class-name class))))
714     (setf (kernel:%class-pcl-class lclass) class)
715     (setf (slot-value class 'wrapper) (kernel:%class-layout lclass)))
716 gerd 1.50 (setf (slot-value class 'finalized-p) t)
717 ram 1.6 (update-pv-table-cache-info class)
718     (setq predicate-name (if predicate-name-p
719     (setf (slot-value class 'predicate-name)
720     (car predicate-name))
721     (or (slot-value class 'predicate-name)
722     (setf (slot-value class 'predicate-name)
723     (make-class-predicate-name (class-name class))))))
724     (make-class-predicate class predicate-name)
725     (add-slot-accessors class direct-slots))
726 ram 1.4
727 gerd 1.58 ;;;
728     ;;; Return a closure for allocating an uninitialized structure
729     ;;; instance of class CLASS.
730     ;;;
731     (defun make-defstruct-allocation-function (class)
732     (let ((dd (get-structure-dd (class-name class))))
733     (lambda ()
734     (let ((instance (kernel::%make-instance (kernel::dd-length dd)))
735     (raw-index (kernel::dd-raw-index dd)))
736     (setf (kernel::%instance-layout instance)
737     (kernel::compiler-layout-or-lose (kernel::dd-name dd)))
738     (when raw-index
739 gerd 1.60 (setf (kernel::%instance-ref instance raw-index)
740     (make-array (kernel::dd-raw-length dd)
741     :element-type '(unsigned-byte 32))))
742 gerd 1.58 instance))))
743    
744 gerd 1.57 (defmethod direct-slot-definition-class ((class structure-class)
745     &rest initargs)
746 ram 1.6 (declare (ignore initargs))
747     (find-class 'structure-direct-slot-definition))
748    
749     (defmethod finalize-inheritance ((class structure-class))
750     nil) ; always finalized
751 wlott 1.1
752     (defun add-slot-accessors (class dslotds)
753     (fix-slot-accessors class dslotds 'add))
754    
755     (defun remove-slot-accessors (class dslotds)
756     (fix-slot-accessors class dslotds 'remove))
757    
758 gerd 1.44 (defun fix-slot-accessors (class dslotds add/remove)
759 ram 1.6 (flet ((fix (gfspec name r/w)
760 wlott 1.1 (let ((gf (ensure-generic-function gfspec)))
761     (case r/w
762     (r (if (eq add/remove 'add)
763 ram 1.6 (add-reader-method class gf name)
764 wlott 1.1 (remove-reader-method class gf)))
765     (w (if (eq add/remove 'add)
766 ram 1.6 (add-writer-method class gf name)
767 wlott 1.1 (remove-writer-method class gf)))))))
768     (dolist (dslotd dslotds)
769 ram 1.6 (let ((slot-name (slot-definition-name dslotd)))
770 gerd 1.44 (dolist (r (slot-definition-readers dslotd))
771     (fix r slot-name 'r))
772     (dolist (w (slot-definition-writers dslotd))
773     (fix w slot-name 'w))))))
774 wlott 1.1
775    
776     (defun add-direct-subclasses (class new)
777     (dolist (n new)
778     (unless (memq class (class-direct-subclasses class))
779     (add-direct-subclass n class))))
780    
781     (defun remove-direct-subclasses (class new)
782     (let ((old (class-direct-superclasses class)))
783     (dolist (o (set-difference old new))
784     (remove-direct-subclass o class))))
785    
786    
787     ;;;
788     ;;;
789     ;;;
790     (defmethod finalize-inheritance ((class std-class))
791     (update-class class t))
792 pmai 1.41
793     (defmethod finalize-inheritance ((class forward-referenced-class))
794     (simple-program-error
795 gerd 1.44 "~@<Forward-referenced classes cannot be finalized: ~A.~@:>"
796 pmai 1.41 class))
797 wlott 1.1
798    
799     ;;;
800 ram 1.4 ;;; Called by :after shared-initialize whenever a class is initialized or
801     ;;; reinitialized. The class may or may not be finalized.
802 wlott 1.1 ;;;
803 gerd 1.44 (defun update-class (class finalizep)
804 pmai 1.40 ;;
805 gerd 1.44 ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which
806     ;; makes the class finalized. When UPDATE-CLASS isn't called from
807     ;; FINALIZE-INHERITANCE, make sure that this finalization invokes
808     ;; FINALIZE-INHERITANCE as per AMOP. Note that we can't simply
809     ;; delay the finalization when CLASS has no forward referenced
810     ;; superclasses because that causes bootstrap problems.
811     (when (and (not (or finalizep (class-finalized-p class)))
812 pmai 1.40 (not (class-has-a-forward-referenced-superclass-p class)))
813     (finalize-inheritance class)
814     (return-from update-class))
815 gerd 1.44 ;;
816     (when (or finalizep
817     (class-finalized-p class)
818 ram 1.6 (not (class-has-a-forward-referenced-superclass-p class)))
819 gerd 1.47 (setf (find-class (class-name class)) class)
820 ram 1.4 (update-cpl class (compute-class-precedence-list class))
821 ram 1.6 (update-slots class (compute-slots class))
822 ram 1.4 (update-gfs-of-class class)
823     (update-inits class (compute-default-initargs class))
824 gerd 1.56 (update-shared-slot-values class)
825 gerd 1.44 (update-ctors 'finalize-inheritance :class class))
826     ;;
827 wlott 1.1 (unless finalizep
828 gerd 1.44 (dolist (sub (class-direct-subclasses class))
829     (update-class sub nil))))
830 gerd 1.56
831     ;;;
832     ;;; Set values of shared slots from initforms inherited from
833     ;;; superclasses, which can't be done before the cpl is known.
834     ;;;
835     (defun update-shared-slot-values (class)
836     (dolist (slot (class-slots class))
837     (when (eq (slot-definition-allocation slot) :class)
838     (let ((cell (assq (slot-definition-name slot) (class-slot-cells class))))
839 gerd 1.62 (when (and cell (eq +slot-unbound+ (cdr cell)))
840 gerd 1.56 (let ((initfn (slot-definition-initfunction slot)))
841     (when initfn
842     (setf (cdr cell) (funcall initfn)))))))))
843 wlott 1.1
844     (defun update-cpl (class cpl)
845 dtc 1.13 (if (class-finalized-p class)
846 gerd 1.55 (unless (and (equal (class-precedence-list class) cpl)
847     (loop for c in cpl never
848     (loop for s in (class-direct-slots c) thereis
849     (eq (slot-definition-allocation s)
850     :class))))
851 dtc 1.13 ;; Need to have the cpl setup before update-lisp-class-layout
852     ;; is called on CMUCL.
853     (setf (slot-value class 'class-precedence-list) cpl)
854     (force-cache-flushes class))
855     (setf (slot-value class 'class-precedence-list) cpl))
856 ram 1.4 (update-class-can-precede-p cpl))
857 gerd 1.51
858 ram 1.4 (defun update-class-can-precede-p (cpl)
859 gerd 1.51 (loop for (class . rest) on cpl do
860     (with-slots (can-precede-list) class
861     (setq can-precede-list
862     (union rest can-precede-list :test #'eq)))))
863 ram 1.4
864     (defun class-can-precede-p (class1 class2)
865 ram 1.6 (member class2 (class-can-precede-list class1)))
866 ram 1.4
867 ram 1.6 (defun update-slots (class eslotds)
868 gerd 1.61 (collect ((instance-slots) (class-slots))
869 ram 1.4 (dolist (eslotd eslotds)
870 pmai 1.38 (ecase (slot-definition-allocation eslotd)
871 gerd 1.51 (:instance (instance-slots eslotd))
872     (:class (class-slots eslotd))))
873 ram 1.6 ;;
874     ;; If there is a change in the shape of the instances then the
875     ;; old class is now obsolete.
876     (let* ((nlayout (mapcar #'slot-definition-name
877 gerd 1.51 (sort (instance-slots) #'<
878 pmai 1.42 :key #'slot-definition-location)))
879 ram 1.6 (nslots (length nlayout))
880 gerd 1.51 (nwrapper-class-slots (compute-class-slots (class-slots)))
881     (owrapper (when (class-finalized-p class)
882     (class-wrapper class)))
883     (olayout (when owrapper
884     (wrapper-instance-slots-layout owrapper)))
885 ram 1.6 (nwrapper
886     (cond ((null owrapper)
887     (make-wrapper nslots class))
888 pmai 1.42 ;;
889     ;; We cannot reuse the old wrapper easily when it
890     ;; has class slot cells, even if these cells are
891 gerd 1.44 ;; EQUAL to the ones used in the new wrapper. The
892 pmai 1.42 ;; class slot cells of OWRAPPER may be referenced
893     ;; from caches, and if we don't change the wrapper,
894     ;; the caches won't notice that something has
895     ;; changed. We could do something here manually,
896     ;; but I don't think it's worth it.
897 ram 1.6 ((and (equal nlayout olayout)
898 pmai 1.42 (null (wrapper-class-slots owrapper)))
899 ram 1.6 owrapper)
900     (t
901     ;;
902     ;; This will initialize the new wrapper to have the same
903     ;; state as the old wrapper. We will then have to change
904     ;; that. This may seem like wasted work (it is), but the
905     ;; spec requires that we call make-instances-obsolete.
906     (make-instances-obsolete class)
907     (class-wrapper class)))))
908 pw 1.9
909 gerd 1.51 (with-slots (wrapper slots finalized-p) class
910 pw 1.9 (update-lisp-class-layout class nwrapper)
911 ram 1.6 (setf slots eslotds
912     (wrapper-instance-slots-layout nwrapper) nlayout
913     (wrapper-class-slots nwrapper) nwrapper-class-slots
914     (wrapper-no-of-instance-slots nwrapper) nslots
915 gerd 1.51 wrapper nwrapper
916     finalized-p t))
917 pw 1.9
918 ram 1.6 (unless (eq owrapper nwrapper)
919 gerd 1.44 (update-inline-access class)
920 gerd 1.46 (update-pv-table-cache-info class)
921     (maybe-update-standard-class-locations class)))))
922 wlott 1.1
923 ram 1.6 (defun compute-class-slots (eslotds)
924 pmai 1.32 (loop for eslotd in eslotds
925     for name = (slot-definition-name eslotd)
926 pmai 1.38 and class = (slot-definition-class eslotd)
927     collect (assoc name (class-slot-cells class))))
928 wlott 1.1
929 ram 1.4 (defun update-gfs-of-class (class)
930 ram 1.6 (when (and (class-finalized-p class)
931     (let ((cpl (class-precedence-list class)))
932     (or (member *the-class-slot-class* cpl)
933     (member *the-class-standard-effective-slot-definition* cpl))))
934 ram 1.4 (let ((gf-table (make-hash-table :test 'eq)))
935     (labels ((collect-gfs (class)
936     (dolist (gf (specializer-direct-generic-functions class))
937     (setf (gethash gf gf-table) t))
938     (mapc #'collect-gfs (class-direct-superclasses class))))
939     (collect-gfs class)
940 pmai 1.32 (maphash (lambda (gf ignore)
941     (declare (ignore ignore))
942     (update-gf-dfun class gf))
943 ram 1.4 gf-table)))))
944 wlott 1.1
945     (defun update-inits (class inits)
946 ram 1.6 (setf (plist-value class 'default-initargs) inits))
947 wlott 1.1
948    
949     ;;;
950     ;;;
951     ;;;
952 ram 1.4 (defmethod compute-default-initargs ((class slot-class))
953 gerd 1.54 (let ((initargs (loop for c in (class-precedence-list class)
954     append (class-direct-default-initargs c))))
955     (delete-duplicates initargs :test #'eq :key #'car :from-end t)))
956 wlott 1.1
957     ;;;
958     ;;; Protocols for constructing direct and effective slot definitions.
959     ;;;
960     ;;;
961     ;;;
962     ;;;
963 gerd 1.57 (defmethod direct-slot-definition-class ((class std-class) &rest initargs)
964 wlott 1.1 (declare (ignore initargs))
965     (find-class 'standard-direct-slot-definition))
966    
967 ram 1.6 (defun make-direct-slotd (class initargs)
968     (let ((initargs (list* :class class initargs)))
969 gerd 1.57 (apply #'make-instance
970     (apply #'direct-slot-definition-class class initargs)
971 gerd 1.44 initargs)))
972 ram 1.6
973 wlott 1.1 ;;;
974 gerd 1.44 ;;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
975     ;;; for each different slot name we find in our superclasses. Each
976     ;;; call receives the class and a list of the dslotds with that name.
977     ;;; The list is in most-specific-first order.
978     ;;;
979     (defmethod compute-slots ((class std-class))
980 gerd 1.61 (collect ((names/slots) (effective))
981 gerd 1.59 (dolist (c (reverse (class-precedence-list class)))
982     (dolist (slot (class-direct-slots c))
983     (let* ((name (slot-definition-name slot))
984     (entry (assq name (names/slots))))
985     (if entry
986     (push slot (cdr entry))
987     (names/slots (list name slot))))))
988     (dolist (e (names/slots) (effective))
989     (effective (compute-effective-slot-definition class (car e) (cdr e))))))
990 gerd 1.44
991 wlott 1.1 ;;;
992 gerd 1.44 ;;; These are the specified AMOP methods.
993 wlott 1.1 ;;;
994    
995 pmai 1.39 (defmethod compute-slots ((class standard-class))
996     (call-next-method))
997 gerd 1.44
998 pmai 1.39 (defmethod compute-slots :around ((class standard-class))
999 gerd 1.44 (loop with slotds = (call-next-method) and location = -1
1000     for slot in slotds do
1001     (setf (slot-definition-location slot)
1002     (ecase (slot-definition-allocation slot)
1003     (:instance
1004     (incf location))
1005     (:class
1006     (let* ((name (slot-definition-name slot))
1007     (from-class (slot-definition-allocation-class slot))
1008     (cell (assq name (class-slot-cells from-class))))
1009     (assert (consp cell))
1010     cell))))
1011     (initialize-internal-slot-functions slot)
1012     finally
1013     (return slotds)))
1014 pmai 1.39
1015     (defmethod compute-slots ((class funcallable-standard-class))
1016     (call-next-method))
1017    
1018     (defmethod compute-slots :around ((class funcallable-standard-class))
1019 gerd 1.44 (labels (;;
1020     ;; Return a list of the names of instance slots in SLOTDS.
1021     (instance-slot-names (slotds)
1022     (loop for e in slotds
1023     when (eq (slot-definition-allocation e) :instance)
1024     collect (slot-definition-name e)))
1025     ;;
1026 pmai 1.39 ;; This sorts slots so that slots of classes later in the CPL
1027 gerd 1.44 ;; come before slots of other classes. This is crucial for
1028     ;; funcallable instances because it ensures that the slots of
1029     ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
1030     ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
1031     ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
1032     ;; a funcallable instance.
1033 pmai 1.39 (compute-layout (eslotds)
1034 gerd 1.44 (loop with first = ()
1035     with names = (instance-slot-names eslotds)
1036     for class in (reverse (class-precedence-list class)) do
1037     (loop for ss in (class-slots class)
1038     as name = (slot-definition-name ss)
1039     when (member name names) do
1040     (push name first)
1041     (setq names (delete name names)))
1042     finally (return (nreverse (nconc names first))))))
1043     ;;
1044 pmai 1.39 (let ((all-slotds (call-next-method))
1045     (instance-slots ())
1046     (class-slots ()))
1047 gerd 1.44 (loop for slotd in all-slotds do
1048     (ecase (slot-definition-allocation slotd)
1049     (:instance (push slotd instance-slots))
1050     (:class (push slotd class-slots))))
1051     (loop with layout = (compute-layout instance-slots)
1052     for slotd in instance-slots do
1053     (setf (slot-definition-location slotd)
1054     (position (slot-definition-name slotd) layout))
1055     (initialize-internal-slot-functions slotd))
1056     (loop for slotd in class-slots
1057     as name = (slot-definition-name slotd)
1058     as from-class = (slot-definition-allocation-class slotd) do
1059     (setf (slot-definition-location slotd)
1060     (assoc name (class-slot-cells from-class)))
1061     (assert (consp (slot-definition-location slotd)))
1062     (initialize-internal-slot-functions slotd))
1063 pmai 1.39 all-slotds)))
1064 ram 1.4
1065 ram 1.6 (defmethod compute-slots ((class structure-class))
1066 pmai 1.32 (mapcan (lambda (superclass)
1067     (mapcar (lambda (dslotd)
1068 gerd 1.52 (compute-effective-slot-definition
1069     class (slot-definition-name dslotd) (list dslotd)))
1070 pmai 1.32 (class-direct-slots superclass)))
1071 ram 1.6 (reverse (slot-value class 'class-precedence-list))))
1072 ram 1.4
1073 ram 1.6 (defmethod compute-slots :around ((class structure-class))
1074     (let ((eslotds (call-next-method)))
1075     (mapc #'initialize-internal-slot-functions eslotds)
1076     eslotds))
1077    
1078 gerd 1.68 (defvar *allow-funny-slot-names* nil)
1079 gerd 1.66
1080     (defmethod initialize-internal-slot-functions :around
1081     ((slotd structure-effective-slot-definition))
1082 gerd 1.68 (let ((*allow-funny-slot-names* t))
1083 gerd 1.66 (call-next-method)))
1084    
1085 gerd 1.52 (defmethod compute-effective-slot-definition
1086     ((class slot-class) slot-name dslotds)
1087     (declare (ignore slot-name))
1088 wlott 1.1 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
1089 gerd 1.57 (class (apply #'effective-slot-definition-class class initargs)))
1090 ram 1.6 (apply #'make-instance class initargs)))
1091 wlott 1.1
1092 gerd 1.57 (defmethod effective-slot-definition-class ((class std-class) &rest initargs)
1093 wlott 1.1 (declare (ignore initargs))
1094 ram 1.6 (find-class 'standard-effective-slot-definition))
1095 wlott 1.1
1096 gerd 1.57 (defmethod effective-slot-definition-class ((class structure-class)
1097     &rest initargs)
1098 ram 1.6 (declare (ignore initargs))
1099     (find-class 'structure-effective-slot-definition))
1100    
1101 ram 1.4 (defmethod compute-effective-slot-definition-initargs
1102     ((class slot-class) direct-slotds)
1103 wlott 1.1 (let* ((name nil)
1104     (initfunction nil)
1105     (initform nil)
1106     (initargs nil)
1107     (allocation nil)
1108 pmai 1.39 (allocation-class nil)
1109 wlott 1.1 (type t)
1110     (namep nil)
1111     (initp nil)
1112 ram 1.6 (allocp nil))
1113 wlott 1.1
1114     (dolist (slotd direct-slotds)
1115     (when slotd
1116     (unless namep
1117 ram 1.4 (setq name (slot-definition-name slotd)
1118 wlott 1.1 namep t))
1119     (unless initp
1120 ram 1.4 (when (slot-definition-initfunction slotd)
1121 ram 1.6 (setq initform (slot-definition-initform slotd)
1122     initfunction (slot-definition-initfunction slotd)
1123 wlott 1.1 initp t)))
1124     (unless allocp
1125 ram 1.4 (setq allocation (slot-definition-allocation slotd)
1126 pmai 1.39 allocation-class (slot-definition-class slotd)
1127 wlott 1.1 allocp t))
1128 ram 1.4 (setq initargs (append (slot-definition-initargs slotd) initargs))
1129     (let ((slotd-type (slot-definition-type slotd)))
1130 pmai 1.32 (setq type (cond ((eq type t) slotd-type)
1131 ram 1.4 ((*subtypep type slotd-type) type)
1132 ram 1.6 (t `(and ,type ,slotd-type)))))))
1133 wlott 1.1 (list :name name
1134     :initform initform
1135     :initfunction initfunction
1136     :initargs initargs
1137     :allocation allocation
1138 pmai 1.39 :allocation-class allocation-class
1139 ram 1.4 :type type
1140 ram 1.6 :class class)))
1141 wlott 1.1
1142 ram 1.6 (defmethod compute-effective-slot-definition-initargs :around
1143     ((class structure-class) direct-slotds)
1144     (let ((slotd (car direct-slotds)))
1145 gerd 1.67 (list* :defstruct-accessor-symbol
1146     (slot-definition-defstruct-accessor-symbol slotd)
1147     :internal-reader-function
1148     (slot-definition-internal-reader-function slotd)
1149     :internal-writer-function
1150     (slot-definition-internal-writer-function slotd)
1151 ram 1.6 (call-next-method))))
1152 wlott 1.1
1153     ;;;
1154     ;;; NOTE: For bootstrapping considerations, these can't use make-instance
1155     ;;; to make the method object. They have to use make-a-method which
1156     ;;; is a specially bootstrapped mechanism for making standard methods.
1157     ;;;
1158 ram 1.6 (defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
1159     (declare (ignore direct-slot initargs))
1160     (find-class 'standard-reader-method))
1161 wlott 1.1
1162 ram 1.6 (defmethod add-reader-method ((class slot-class) generic-function slot-name)
1163     (add-method generic-function
1164     (make-a-method 'standard-reader-method
1165     ()
1166     (list (or (class-name class) 'object))
1167     (list class)
1168     (make-reader-method-function class slot-name)
1169     "automatically generated reader method"
1170     slot-name)))
1171 wlott 1.1
1172 ram 1.6 (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
1173 ram 1.5 (declare (ignore direct-slot initargs))
1174 ram 1.6 (find-class 'standard-writer-method))
1175 ram 1.5
1176 ram 1.6 (defmethod add-writer-method ((class slot-class) generic-function slot-name)
1177     (add-method generic-function
1178     (make-a-method 'standard-writer-method
1179     ()
1180     (list 'new-value (or (class-name class) 'object))
1181     (list *the-class-t* class)
1182     (make-writer-method-function class slot-name)
1183     "automatically generated writer method"
1184     slot-name)))
1185 ram 1.5
1186 ram 1.6 (defmethod add-boundp-method ((class slot-class) generic-function slot-name)
1187     (add-method generic-function
1188     (make-a-method 'standard-boundp-method
1189     ()
1190     (list (or (class-name class) 'object))
1191     (list class)
1192     (make-boundp-method-function class slot-name)
1193     "automatically generated boundp method"
1194     slot-name)))
1195 ram 1.5
1196 ram 1.4 (defmethod remove-reader-method ((class slot-class) generic-function)
1197 wlott 1.1 (let ((method (get-method generic-function () (list class) nil)))
1198 gerd 1.44 (when method
1199     (remove-method generic-function method))))
1200 wlott 1.1
1201 ram 1.4 (defmethod remove-writer-method ((class slot-class) generic-function)
1202 gerd 1.44 (let ((method (get-method generic-function ()
1203     (list *the-class-t* class) nil)))
1204     (when method
1205     (remove-method generic-function method))))
1206 wlott 1.1
1207 ram 1.4 (defmethod remove-boundp-method ((class slot-class) generic-function)
1208     (let ((method (get-method generic-function () (list class) nil)))
1209 gerd 1.44 (when method
1210     (remove-method generic-function method))))
1211 ram 1.4
1212 wlott 1.1
1213     ;;;
1214     ;;; make-reader-method-function and make-write-method function are NOT part of
1215     ;;; the standard protocol. They are however useful, PCL makes uses makes use
1216     ;;; of them internally and documents them for PCL users.
1217     ;;;
1218     ;;; *** This needs work to make type testing by the writer functions which
1219     ;;; *** do type testing faster. The idea would be to have one constructor
1220     ;;; *** for each possible type test. In order to do this it would be nice
1221     ;;; *** to have help from inform-type-system-about-class and friends.
1222     ;;;
1223     ;;; *** There is a subtle bug here which is going to have to be fixed.
1224     ;;; *** Namely, the simplistic use of the template has to be fixed. We
1225     ;;; *** have to give the optimize-slot-value method the user might have
1226     ;;; *** defined for this metclass a chance to run.
1227     ;;;
1228 ram 1.6 (defmethod make-reader-method-function ((class slot-class) slot-name)
1229     (make-std-reader-method-function (class-name class) slot-name))
1230 wlott 1.1
1231 ram 1.6 (defmethod make-writer-method-function ((class slot-class) slot-name)
1232     (make-std-writer-method-function (class-name class) slot-name))
1233 ram 1.5
1234 ram 1.6 (defmethod make-boundp-method-function ((class slot-class) slot-name)
1235     (make-std-boundp-method-function (class-name class) slot-name))
1236 ram 1.5
1237 wlott 1.1
1238     ;;;; inform-type-system-about-class
1239     ;;;
1240 pw 1.26 ;;; This is NOT part of the standard protocol. It is an internal mechanism
1241 wlott 1.1 ;;; which PCL uses to *try* and tell the type system about class definitions.
1242     ;;; In a more fully integrated implementation of CLOS, the type system would
1243     ;;; know about class objects and class names in a more fundamental way and
1244     ;;; the mechanism used to inform the type system about new classes would be
1245     ;;; different.
1246     ;;;
1247     (defmethod inform-type-system-about-class ((class std-class) name)
1248 pw 1.26 ;; Maybe add skeleton lisp:standard-class to avoid undefined-function
1249     ;; compiler warnings. Not otherwise needed in this implementation.
1250 gerd 1.44 (inform-type-system-about-std-class name)
1251     (set-class-translation class name))
1252    
1253     (defmethod inform-type-system-about-class ((class funcallable-standard-class)
1254     name)
1255     (set-class-translation class name))
1256 pw 1.26
1257 gerd 1.44 (defmethod inform-type-system-about-class ((class structure-class) name)
1258     (set-class-translation class name))
1259    
1260     (defmethod inform-type-system-about-class ((class condition-class) name)
1261     (set-class-translation class name))
1262 pw 1.26
1263 gerd 1.50 (defmethod inform-type-system-about-class ((class forward-referenced-class)
1264     name)
1265     (inform-type-system-about-std-class name)
1266     (set-class-translation class name))
1267    
1268 wlott 1.1
1269     (defmethod compatible-meta-class-change-p (class proto-new-class)
1270     (eq (class-of class) (class-of proto-new-class)))
1271    
1272 ram 1.4 (defmethod validate-superclass ((class class) (new-super class))
1273     (or (eq new-super *the-class-t*)
1274     (eq (class-of class) (class-of new-super))))
1275 wlott 1.1
1276 dtc 1.16 (defmethod validate-superclass ((class standard-class) (new-super std-class))
1277     (let ((new-super-meta-class (class-of new-super)))
1278     (or (eq new-super-meta-class *the-class-std-class*)
1279     (eq (class-of class) new-super-meta-class))))
1280 ram 1.4
1281 wlott 1.1
1282     ;;;
1283 pmai 1.37 ;;; Force the flushing of caches by creating a new wrapper for CLASS,
1284     ;;; if necessary.
1285 wlott 1.1 ;;;
1286 pmai 1.37 ;;; If the LAYOUT-INVALID slot of CLASS's wrapper is
1287     ;;;
1288     ;;; -- (:FLUSH <new wrapper>) or (:OBSOLETE <new wrapper>), there's
1289     ;;; nothing to do. The new wrapper has already been created.
1290     ;;;
1291     ;;; -- :INVALID, then it has been set to that value by a previous
1292     ;;; call to REGISTER-LAYOUT for a superclass S of CLASS; S's
1293     ;;; wrapper has been invalidated together with its subclasses. In
1294     ;;; this case, CLASS's caches must obviously be flushed, too, like
1295     ;;; S's. So, make a new wrapper for CLASS, and translate kernel's
1296     ;;; :INVALID to PCL (:FLUSH <new wrapper>). UPDATE-SLOTS can later
1297     ;;; decide if it wants to make this (:OBSOLETE ...).
1298     ;;;
1299     ;;; -- NIL, then the wrapper is still valid, in which case we do
1300     ;;; the same as for :INVALID, but for the obviously slightly
1301     ;;; different reason.
1302 wlott 1.1 ;;;
1303     (defun force-cache-flushes (class)
1304 pmai 1.37 (let* ((owrapper (class-wrapper class)))
1305     (when (or (not (invalid-wrapper-p owrapper))
1306     (eq :invalid (kernel:layout-invalid owrapper)))
1307 ram 1.6 (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1308     class)))
1309 wlott 1.1 (setf (wrapper-instance-slots-layout nwrapper)
1310     (wrapper-instance-slots-layout owrapper))
1311     (setf (wrapper-class-slots nwrapper)
1312     (wrapper-class-slots owrapper))
1313 pmai 1.34 (with-pcl-lock
1314 pw 1.9 (update-lisp-class-layout class nwrapper)
1315 wlott 1.1 (setf (slot-value class 'wrapper) nwrapper)
1316 pmai 1.32 (invalidate-wrapper owrapper :flush nwrapper))))))
1317 wlott 1.1
1318     (defun flush-cache-trap (owrapper nwrapper instance)
1319     (declare (ignore owrapper))
1320 gerd 1.44 (cond ((std-instance-p instance)
1321     (setf (std-instance-wrapper instance) nwrapper))
1322     ((fsc-instance-p instance)
1323     (setf (fsc-instance-wrapper instance) nwrapper))
1324     (t
1325     (internal-error "Internal error."))))
1326 wlott 1.1
1327    
1328     ;;;
1329     ;;; make-instances-obsolete can be called by user code. It will cause the
1330     ;;; next access to the instance (as defined in 88-002R) to trap through the
1331     ;;; update-instance-for-redefined-class mechanism.
1332     ;;;
1333     (defmethod make-instances-obsolete ((class std-class))
1334 ram 1.6 (let* ((owrapper (class-wrapper class))
1335     (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1336     class)))
1337 wlott 1.1 (setf (wrapper-instance-slots-layout nwrapper)
1338     (wrapper-instance-slots-layout owrapper))
1339     (setf (wrapper-class-slots nwrapper)
1340     (wrapper-class-slots owrapper))
1341 pmai 1.34 (with-pcl-lock
1342 pw 1.9 (update-lisp-class-layout class nwrapper)
1343 wlott 1.1 (setf (slot-value class 'wrapper) nwrapper)
1344 pmai 1.32 (invalidate-wrapper owrapper :obsolete nwrapper)
1345 ram 1.6 class)))
1346 wlott 1.1
1347     (defmethod make-instances-obsolete ((class symbol))
1348     (make-instances-obsolete (find-class class)))
1349    
1350    
1351     ;;;
1352     ;;; obsolete-instance-trap is the internal trap that is called when we see
1353     ;;; an obsolete instance. The times when it is called are:
1354     ;;; - when the instance is involved in method lookup
1355     ;;; - when attempting to access a slot of an instance
1356     ;;;
1357     ;;; It is not called by class-of, wrapper-of, or any of the low-level instance
1358     ;;; access macros.
1359     ;;;
1360     ;;; Of course these times when it is called are an internal implementation
1361     ;;; detail of PCL and are not part of the documented description of when the
1362     ;;; obsolete instance update happens. The documented description is as it
1363     ;;; appears in 88-002R.
1364     ;;;
1365     ;;; This has to return the new wrapper, so it counts on all the methods on
1366     ;;; obsolete-instance-trap-internal to return the new wrapper. It also does
1367     ;;; a little internal error checking to make sure that the traps are only
1368     ;;; happening when they should, and that the trap methods are computing
1369     ;;; apropriate new wrappers.
1370     ;;;
1371 pw 1.9
1372     ;;; obsolete-instance-trap might be called on structure instances
1373     ;;; after a structure is redefined. In most cases, obsolete-instance-trap
1374     ;;; will not be able to fix the old instance, so it must signal an
1375     ;;; error. The hard part of this is that the error system and debugger
1376     ;;; might cause obsolete-instance-trap to be called again, so in that
1377     ;;; case, we have to return some reasonable wrapper, instead.
1378    
1379     (defvar *in-obsolete-instance-trap* nil)
1380 gerd 1.44
1381 pw 1.9 (defvar *the-wrapper-of-structure-object*
1382     (class-wrapper (find-class 'structure-object)))
1383    
1384     (define-condition obsolete-structure (error)
1385     ((datum :reader obsolete-structure-datum :initarg :datum))
1386     (:report
1387     (lambda (condition stream)
1388     ;; Don't try to print the structure, since it probably
1389     ;; won't work.
1390 gerd 1.44 (format stream "~@<Obsolete structure error in ~S ~
1391     for a structure of type ~S.~@:>"
1392 pw 1.9 (conditions::condition-function-name condition)
1393     (type-of (obsolete-structure-datum condition))))))
1394    
1395     (defun obsolete-instance-trap (owrapper nwrapper instance)
1396 pw 1.25 (if (not (pcl-instance-p instance))
1397 pw 1.9 (if *in-obsolete-instance-trap*
1398     *the-wrapper-of-structure-object*
1399     (let ((*in-obsolete-instance-trap* t))
1400     (error 'obsolete-structure :datum instance)))
1401     (let* ((class (wrapper-class* nwrapper))
1402     (copy (allocate-instance class)) ;??? allocate-instance ???
1403     (olayout (wrapper-instance-slots-layout owrapper))
1404     (nlayout (wrapper-instance-slots-layout nwrapper))
1405     (oslots (get-slots instance))
1406     (nslots (get-slots copy))
1407     (oclass-slots (wrapper-class-slots owrapper))
1408     (added ())
1409     (discarded ())
1410     (plist ()))
1411     ;; local --> local transfer
1412     ;; local --> shared discard
1413     ;; local --> -- discard
1414     ;; shared --> local transfer
1415     ;; shared --> shared discard
1416     ;; shared --> -- discard
1417     ;; -- --> local add
1418     ;; -- --> shared --
1419     ;;
1420     ;; Go through all the old local slots.
1421 pmai 1.32 ;;
1422     (loop for name in olayout and opos from 0
1423     as npos = (posq name nlayout)
1424     if npos do
1425 gerd 1.44 (setf (slot-ref nslots npos)
1426     (slot-ref oslots opos))
1427 pmai 1.32 else do
1428     (push name discarded)
1429 gerd 1.44 (unless (eq (slot-ref oslots opos) +slot-unbound+)
1430 pmai 1.32 (setf (getf plist name)
1431 gerd 1.44 (slot-ref oslots opos))))
1432 pw 1.9 ;;
1433     ;; Go through all the old shared slots.
1434     ;;
1435 pmai 1.32 (loop for (name . val) in oclass-slots
1436     for npos = (posq name nlayout)
1437     if npos do
1438 gerd 1.44 (setf (slot-ref nslots npos) val)
1439 pmai 1.32 else do
1440     (push name discarded)
1441 pmai 1.35 (unless (eq val +slot-unbound+)
1442 pmai 1.32 (setf (getf plist name) val)))
1443 pw 1.9 ;;
1444     ;; Go through all the new local slots to compute the added slots.
1445     ;;
1446     (dolist (nlocal nlayout)
1447     (unless (or (memq nlocal olayout)
1448     (assq nlocal oclass-slots))
1449     (push nlocal added)))
1450 wlott 1.1
1451 pw 1.9 (swap-wrappers-and-slots instance copy)
1452 wlott 1.1
1453 pw 1.9 (update-instance-for-redefined-class instance
1454     added
1455     discarded
1456     plist)
1457     nwrapper)))
1458 wlott 1.1
1459    
1460     ;;;
1461     ;;;
1462     ;;;
1463 pmai 1.29 (defun change-class-internal (instance new-class initargs)
1464 ram 1.6 (let* ((old-class (class-of instance))
1465 pw 1.9 (copy (allocate-instance new-class))
1466     (new-wrapper (get-wrapper copy))
1467 ram 1.6 (old-wrapper (class-wrapper old-class))
1468     (old-layout (wrapper-instance-slots-layout old-wrapper))
1469     (new-layout (wrapper-instance-slots-layout new-wrapper))
1470     (old-slots (get-slots instance))
1471 pw 1.9 (new-slots (get-slots copy))
1472 ram 1.6 (old-class-slots (wrapper-class-slots old-wrapper)))
1473    
1474 wlott 1.1 ;;
1475     ;; "The values of local slots specified by both the class Cto and
1476     ;; Cfrom are retained. If such a local slot was unbound, it remains
1477     ;; unbound."
1478 pmai 1.32 ;;
1479     (loop for new-slot in new-layout and new-position from 0
1480     for old-position = (posq new-slot old-layout)
1481     when old-position do
1482 gerd 1.44 (setf (slot-ref new-slots new-position)
1483     (slot-ref old-slots old-position)))
1484 wlott 1.1 ;;
1485     ;; "The values of slots specified as shared in the class Cfrom and
1486     ;; as local in the class Cto are retained."
1487     ;;
1488 pmai 1.32 (loop for (name . val) in old-class-slots
1489     for new-position = (posq name new-layout)
1490     when new-position do
1491 gerd 1.44 (setf (slot-ref new-slots new-position) val))
1492 wlott 1.1
1493     ;; Make the copy point to the old instance's storage, and make the
1494     ;; old instance point to the new storage.
1495 pw 1.9 (swap-wrappers-and-slots instance copy)
1496 wlott 1.1
1497 pmai 1.29 (apply #'update-instance-for-different-class copy instance initargs)
1498 wlott 1.1 instance))
1499    
1500     (defmethod change-class ((instance standard-object)
1501 pmai 1.29 (new-class standard-class)
1502 gerd 1.60 &rest initargs &key)
1503 pmai 1.29 (change-class-internal instance new-class initargs))
1504 wlott 1.1
1505 dtc 1.15 (defmethod change-class ((instance funcallable-standard-object)
1506 pmai 1.29 (new-class funcallable-standard-class)
1507 gerd 1.60 &rest initargs &key)
1508 pmai 1.29 (change-class-internal instance new-class initargs))
1509 dtc 1.17
1510     (defmethod change-class ((instance standard-object)
1511 pmai 1.29 (new-class funcallable-standard-class)
1512 gerd 1.60 &rest initargs &key)
1513 pmai 1.29 (declare (ignore initargs))
1514 gerd 1.44 (error "~@<Can't change the class of ~S to ~S ~
1515     because it isn't already an instance with metaclass ~S.~@:>"
1516 dtc 1.17 instance new-class 'standard-class))
1517    
1518     (defmethod change-class ((instance funcallable-standard-object)
1519 pmai 1.29 (new-class standard-class)
1520 gerd 1.60 &rest initargs &key)
1521 pmai 1.29 (declare (ignore initargs))
1522 gerd 1.44 (error "~@<Can't change the class of ~S to ~S ~
1523     because it isn't already an instance with metaclass ~S.~@:>"
1524 dtc 1.17 instance new-class 'funcallable-standard-class))
1525 wlott 1.1
1526 gerd 1.60 (defmethod change-class ((instance t) (new-class-name symbol)
1527     &rest initargs &key)
1528 pmai 1.29 (apply #'change-class instance (find-class new-class-name) initargs))
1529 wlott 1.1
1530    
1531    
1532     ;;;
1533     ;;; The metaclass BUILT-IN-CLASS
1534     ;;;
1535     ;;; This metaclass is something of a weird creature. By this point, all
1536     ;;; instances of it which will exist have been created, and no instance
1537     ;;; is ever created by calling MAKE-INSTANCE.
1538     ;;;
1539     ;;; But, there are other parts of the protcol we must follow and those
1540     ;;; definitions appear here.
1541     ;;;
1542     (defmethod shared-initialize :before
1543     ((class built-in-class) slot-names &rest initargs)
1544 ram 1.5 (declare (ignore slot-names initargs))
1545 gerd 1.44 (error "Attempt to initialize or reinitialize a built-in class."))
1546 wlott 1.1
1547 ram 1.6 (defmethod class-direct-slots ((class built-in-class)) ())
1548     (defmethod class-slots ((class built-in-class)) ())
1549     (defmethod class-direct-default-initargs ((class built-in-class)) ())
1550     (defmethod class-default-initargs ((class built-in-class)) ())
1551    
1552 ram 1.4 (defmethod validate-superclass ((c class) (s built-in-class))
1553 gerd 1.44 (or (eq s *the-class-t*)
1554     (eq s *the-class-stream*)))
1555 wlott 1.1
1556 ram 1.4
1557 wlott 1.1
1558     ;;;
1559     ;;;
1560     ;;;
1561    
1562 gerd 1.44 (macrolet ((frob (method)
1563     `(defmethod ,method ((class forward-referenced-class))
1564     (declare (ignore class))
1565     ())))
1566     (frob class-direct-slots)
1567     (frob class-direct-default-initargs))
1568    
1569     (macrolet ((frob (method)
1570     `(defmethod ,method ((class forward-referenced-class))
1571     (error "~@<~S called for forward referenced class ~S.~@:>"
1572     ',method class))))
1573     (frob class-default-initargs)
1574     (frob class-precedence-list)
1575     (frob class-slots))
1576    
1577 ram 1.4 (defmethod validate-superclass ((c slot-class)
1578 dtc 1.16 (f forward-referenced-class))
1579 pmai 1.32 t)
1580 wlott 1.1
1581    
1582     ;;;
1583     ;;;
1584     ;;;
1585    
1586     (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
1587     (pushnew dependent (plist-value metaobject 'dependents)))
1588    
1589     (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
1590     (setf (plist-value metaobject 'dependents)
1591     (delete dependent (plist-value metaobject 'dependents))))
1592    
1593     (defmethod map-dependents ((metaobject dependent-update-mixin) function)
1594     (dolist (dependent (plist-value metaobject 'dependents))
1595 ram 1.2 (funcall function dependent)))
1596 ram 1.4
1597 gerd 1.44
1598     ;;;
1599     ;;; Conditions
1600     ;;;
1601 gerd 1.45 (defmethod class-default-initargs ((class condition-class)) ())
1602     (defmethod class-direct-default-initargs ((class condition-class)) ())
1603    
1604 gerd 1.44 (defmethod shared-initialize :after ((class condition-class) slot-names
1605 gerd 1.63 &key direct-slots direct-superclasses)
1606 gerd 1.44 (declare (ignore slot-names))
1607     (let ((kernel-class (kernel::find-class (class-name class))))
1608     (with-slots (wrapper class-precedence-list prototype predicate-name
1609     (direct-supers direct-superclasses))
1610     class
1611 gerd 1.63 (setf (slot-value class 'direct-slots)
1612     (mapcar (lambda (pl) (make-direct-slotd class pl))
1613     direct-slots))
1614 gerd 1.50 (setf (slot-value class 'finalized-p) t)
1615 gerd 1.44 (setf (kernel:%class-pcl-class kernel-class) class)
1616     (setq direct-supers direct-superclasses)
1617     (setq wrapper (kernel:%class-layout kernel-class))
1618     (setq class-precedence-list (compute-class-precedence-list class))
1619     (add-direct-subclasses class direct-superclasses)
1620     (setq predicate-name (make-class-predicate-name (class-name class)))
1621 gerd 1.63 (make-class-predicate class predicate-name)
1622 gerd 1.65 (setf (slot-value class 'slots) (compute-slots class))))
1623     ;;
1624     ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
1625     ;; override condition accessors with generic functions. We do this
1626     ;; differently.
1627     (update-pv-table-cache-info class))
1628 gerd 1.44
1629 gerd 1.63 (defmethod direct-slot-definition-class
1630     ((class condition-class) &rest initargs)
1631     (declare (ignore initargs))
1632     (find-class 'condition-direct-slot-definition))
1633    
1634     (defmethod effective-slot-definition-class
1635     ((class condition-class) &rest initargs)
1636     (declare (ignore initargs))
1637     (find-class 'condition-effective-slot-definition))
1638    
1639     (defmethod finalize-inheritance ((class condition-class))
1640     nil)
1641 gerd 1.64
1642     (defmethod compute-effective-slot-definition
1643     ((class condition-class) slot-name dslotds)
1644     (let ((slotd (call-next-method)))
1645     (setf (slot-definition-reader-function slotd)
1646     (lambda (x)
1647     (handler-case
1648     (conditions::condition-reader-function x slot-name)
1649 gerd 1.70 (error () (values (slot-unbound class x slot-name))))))
1650 gerd 1.64 (setf (slot-definition-writer-function slotd)
1651     (lambda (v x)
1652     (conditions::condition-writer-function x v slot-name)))
1653     (setf (slot-definition-boundp-function slotd)
1654     (lambda (x)
1655     (multiple-value-bind (v c)
1656     (ignore-errors
1657     (conditions::condition-reader-function x slot-name))
1658     (declare (ignore v))
1659     (null c))))
1660     slotd))
1661 gerd 1.63
1662     (defmethod compute-slots ((class condition-class))
1663     (mapcan (lambda (superclass)
1664     (mapcar (lambda (dslotd)
1665     (compute-effective-slot-definition
1666     class (slot-definition-name dslotd) (list dslotd)))
1667     (class-direct-slots superclass)))
1668     (reverse (slot-value class 'class-precedence-list))))
1669    
1670 gerd 1.65 (defmethod compute-slots :around ((class condition-class))
1671     (let ((eslotds (call-next-method)))
1672     (mapc #'initialize-internal-slot-functions eslotds)
1673     eslotds))

  ViewVC Help
Powered by ViewVC 1.1.5