/[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.74 - (hide annotations)
Sat Sep 25 22:09:29 2004 UTC (9 years, 6 months ago) by rtoy
Branch: MAIN
CVS Tags: snapshot-2004-10, snapshot-2004-12, snapshot-2004-11, snapshot-2005-01
Changes since 1.73: +5 -2 lines
When creating an eql specializer, tell the type system aboout this eql
specializer.

Fixes a bug reported by Bruno Haible, cmucl-imp, 2004-09-15.
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.74 "$Header: /tiger/var/lib/cvsroots/cmucl/src/pcl/std-class.lisp,v 1.74 2004/09/25 22:09:29 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 rtoy 1.74 (setf (slot-value specl 'type) `(eql ,(specializer-object specl)))
352     ;; Tell the type system about this eql specializer type.
353     (setf (info type translator specl)
354     (constantly (kernel:make-member-type :members (list (specializer-object specl))))))
355 ram 1.4
356 wlott 1.1
357    
358 dtc 1.24 (defun real-load-defclass (name metaclass-name supers slots other)
359 gerd 1.44 (apply #'ensure-class name :metaclass metaclass-name
360     :direct-superclasses supers
361     :direct-slots slots
362     other))
363 wlott 1.1
364 phg 1.7 (setf (gdefinition 'load-defclass) #'real-load-defclass)
365 ram 1.6
366 gerd 1.69 ;;;
367     ;;; The DEFCLASS spec says that this redefines a class with proper
368     ;;; name NAME, where S is the proper name of class C if S =
369     ;;; (CLASS-NAME C) and (FIND-CLASS S) = C.
370     ;;;
371 ram 1.6 (defun ensure-class (name &rest all)
372 gerd 1.69 (let ((class (find-class name nil)))
373     (when (and class (neq name (class-name class)))
374     (setq class nil))
375     (apply #'ensure-class-using-class class name all)))
376 ram 1.6
377 gerd 1.47 (defmethod ensure-class-using-class ((class null) name &rest args &key)
378 ram 1.6 (multiple-value-bind (meta initargs)
379     (ensure-class-values class args)
380 gerd 1.44 (inform-type-system-about-class (class-prototype meta) name)
381 gerd 1.71 (let ((class (apply #'make-instance meta :name name initargs)))
382     (setf (find-class name) class)
383     (inform-type-system-about-class class name)
384     class)))
385 ram 1.6
386 gerd 1.47 (defmethod ensure-class-using-class ((class pcl-class) name &rest args &key)
387 ram 1.6 (multiple-value-bind (meta initargs)
388     (ensure-class-values class args)
389 gerd 1.44 (unless (eq (class-of class) meta)
390 gerd 1.49 (apply #'change-class class meta initargs))
391 ram 1.6 (apply #'reinitialize-instance class initargs)
392 phg 1.7 (setf (find-class name) class)
393 gerd 1.44 (inform-type-system-about-class class name)
394 ram 1.6 class))
395    
396 phg 1.7 (defmethod class-predicate-name ((class t))
397     'function-returning-nil)
398    
399 wlott 1.1 (defun ensure-class-values (class args)
400     (let* ((initargs (copy-list args))
401     (unsupplied (list 1))
402     (supplied-meta (getf initargs :metaclass unsupplied))
403     (supplied-supers (getf initargs :direct-superclasses unsupplied))
404 gerd 1.44 (meta (cond ((neq supplied-meta unsupplied)
405     (find-class supplied-meta))
406     ((or (null class)
407     (forward-referenced-class-p class))
408     *the-class-standard-class*)
409     (t
410     (class-of class)))))
411 gerd 1.50 (flet ((fix-super (super)
412     (cond ((classp super)
413     super)
414     ((legal-class-name-p super)
415     (or (find-class super nil)
416     (make-instance 'forward-referenced-class
417     :name super)))
418     (t
419 pmai 1.33 (simple-program-error
420 gerd 1.50 "~@<~S is not a class or a legal class name.~@:>"
421     super)))))
422 pmai 1.31 ;;
423     ;; CLHS: signal PROGRAM-ERROR, if
424     ;; (a) there are any duplicate slot names
425     ;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or
426     ;; :DOCUMENTATION appears more than one in a single slot description.
427     (loop for (slot . more) on (getf initargs :direct-slots)
428     for slot-name = (getf slot :name)
429     if (some (lambda (s) (eq slot-name (getf s :name))) more) do
430 pmai 1.33 (simple-program-error
431 gerd 1.44 "~@<More than one direct slot with name ~S.~@:>"
432 pmai 1.33 slot-name)
433 pmai 1.31 else do
434     (loop for (option value . more) on slot by #'cddr
435 gerd 1.44 if (and (member option '(:allocation :type :initform
436     :documentation))
437     (not (eq unsupplied
438     (getf more option unsupplied)))) do
439     (simple-program-error
440     "~@<Duplicate slot option ~S for slot ~S.~@:>"
441     option slot-name)
442     else if (and (eq option :readers)
443     (notevery #'symbolp value)) do
444     (simple-program-error
445     "~@<Slot ~S: slot reader names must be symbols.~@:>"
446     slot-name)
447     else if (and (eq option :initargs)
448     (notevery #'symbolp value)) do
449 pmai 1.33 (simple-program-error
450 gerd 1.44 "~@<Slot ~S: initarg names must be symbols.~@:>"
451     slot-name)))
452 pmai 1.31 ;;
453     ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name
454     ;; appears more than once in :DEFAULT-INITARGS class option.
455     (loop for (initarg . more) on (getf initargs :direct-default-initargs)
456     for name = (car initarg)
457     when (some (lambda (a) (eq (car a) name)) more) do
458 pmai 1.33 (simple-program-error
459 gerd 1.44 "~@<Duplicate initialization argument ~
460     name ~S in ~s of class ~A.~@:>"
461     name :default-initargs class))
462     ;;
463     (loop for (arg value) on initargs by #'cddr
464     count (eq arg :metaclass) into metaclass
465     count (eq arg :direct-default-initargs) into default-initargs
466     when (or (> metaclass 1) (> default-initargs 1)) do
467     (simple-program-error
468     "~@<Class ~S: More than one ~S specified~@:>"
469     class (if (eq arg :direct-default-initargs)
470     :default-initargs arg)))
471     (remf initargs :metaclass)
472     (remf initargs :direct-superclasses)
473 pmai 1.31 ;;
474 wlott 1.1 (values meta
475 gerd 1.44 (nconc (when (neq supplied-supers unsupplied)
476     (list :direct-superclasses
477     (mapcar #'fix-super supplied-supers)))
478     initargs)))))
479 wlott 1.1
480    
481     ;;;
482     ;;;
483     ;;;
484     (defmethod shared-initialize :after
485     ((class std-class)
486     slot-names
487 ram 1.2 &key (direct-superclasses nil direct-superclasses-p)
488     (direct-slots nil direct-slots-p)
489 ram 1.4 (direct-default-initargs nil direct-default-initargs-p)
490     (predicate-name nil predicate-name-p))
491 wlott 1.1 (declare (ignore slot-names))
492 pmai 1.28 (cond ((or direct-superclasses-p
493     (null (slot-value class 'direct-superclasses)))
494 dtc 1.17 (setq direct-superclasses
495     (or direct-superclasses
496     (list (if (funcallable-standard-class-p class)
497     *the-class-funcallable-standard-object*
498     *the-class-standard-object*))))
499     (dolist (superclass direct-superclasses)
500     (unless (validate-superclass class superclass)
501 gerd 1.44 (error "~@<The class ~S was specified as a ~
502     super-class of the class ~S, ~
503     but the meta-classes ~S and ~S are incompatible. ~
504     Define a method for ~S to avoid this error.~@:>"
505 dtc 1.17 superclass class (class-of superclass) (class-of class)
506     'validate-superclass)))
507     (setf (slot-value class 'direct-superclasses) direct-superclasses))
508     (t
509     (setq direct-superclasses (slot-value class 'direct-superclasses))))
510 ram 1.2 (setq direct-slots
511     (if direct-slots-p
512     (setf (slot-value class 'direct-slots)
513 gerd 1.50 (mapcar (lambda (pl) (make-direct-slotd class pl))
514     direct-slots))
515 ram 1.2 (slot-value class 'direct-slots)))
516     (if direct-default-initargs-p
517 gerd 1.50 (setf (plist-value class 'direct-default-initargs)
518     direct-default-initargs)
519     (setq direct-default-initargs
520     (plist-value class 'direct-default-initargs)))
521 gerd 1.56 ;;
522     ;; Initialize shared slots. A class may inherit initforms for
523     ;; shared slots from superclasses. Such initializations are
524     ;; done in UPDATE-CLASS-SLOT-VALUES.
525 gerd 1.61 (collect ((cells))
526 gerd 1.56 (dolist (dslotd direct-slots)
527     (when (eq (slot-definition-allocation dslotd) :class)
528     (let ((initfn (slot-definition-initfunction dslotd)))
529     (cells (cons (slot-definition-name dslotd)
530     (if initfn
531     (funcall initfn)
532     +slot-unbound+))))))
533     (setf (plist-value class 'class-slot-cells) (cells)))
534     ;;
535 ram 1.6 (setq predicate-name (if predicate-name-p
536     (setf (slot-value class 'predicate-name)
537     (car predicate-name))
538     (or (slot-value class 'predicate-name)
539     (setf (slot-value class 'predicate-name)
540     (make-class-predicate-name (class-name class))))))
541 wlott 1.1 (add-direct-subclasses class direct-superclasses)
542 gerd 1.47 (make-class-predicate class predicate-name)
543 ram 1.6 (update-class class nil)
544 gerd 1.50 (add-slot-accessors class direct-slots)
545     (make-preliminary-layout class))
546    
547     (defmethod shared-initialize :after ((class forward-referenced-class)
548     slot-names &key &allow-other-keys)
549     (declare (ignore slot-names))
550     (make-preliminary-layout class))
551    
552     ;;;
553     ;;; Give CLASS a preliminary layout, if it doesn't have a layout
554     ;;; already. This is done to make CLASS known to the type system
555     ;;; before the class is finalized, and is a consequence of the class
556     ;;; schizophrenia we are suffering from.
557     ;;;
558     (defvar *allow-forward-referenced-classes-in-cpl-p* nil)
559    
560     (defun make-preliminary-layout (class)
561     (flet ((compute-preliminary-cpl (root)
562     (let ((*allow-forward-referenced-classes-in-cpl-p* t))
563     (compute-class-precedence-list root))))
564     (unless (class-finalized-p class)
565     (let ((name (class-name class)))
566     (setf (find-class name) class)
567     (inform-type-system-about-class class name)
568     (let ((layout (make-wrapper 0 class))
569     (kernel-class (kernel::find-class name)))
570     (setf (kernel:layout-class layout) kernel-class)
571     (setf (kernel:%class-pcl-class kernel-class) class)
572     (setf (slot-value class 'wrapper) layout)
573     (let ((cpl (compute-preliminary-cpl class)))
574     (setf (kernel:layout-inherits layout)
575     (kernel:order-layout-inherits
576     (map 'simple-vector #'class-wrapper
577     (reverse (rest cpl))))))
578     (kernel:register-layout layout :invalidate t)
579 gerd 1.53 (setf (kernel:%class-layout kernel-class) layout)
580     (mapc #'make-preliminary-layout (class-direct-subclasses class)))))))
581 wlott 1.1
582 ram 1.6 (defmethod shared-initialize :before ((class class) slot-names &key name)
583     (declare (ignore slot-names name))
584 ram 1.4 (setf (slot-value class 'type) `(class ,class))
585     (setf (slot-value class 'class-eq-specializer)
586     (make-instance 'class-eq-specializer :class class)))
587    
588 pw 1.22 (defmethod reinitialize-instance :before ((class slot-class)
589     &key direct-superclasses)
590     (remove-direct-subclasses class direct-superclasses)
591 wlott 1.1 (remove-slot-accessors class (class-direct-slots class)))
592    
593 ram 1.6 (defmethod reinitialize-instance :after ((class slot-class)
594 wlott 1.1 &rest initargs
595     &key)
596     (map-dependents class
597 pmai 1.32 (lambda (dependent)
598     (apply #'update-dependent class dependent initargs))))
599 ram 1.4
600 ram 1.6 (defmethod shared-initialize :after
601     ((class structure-class)
602     slot-names
603     &key (direct-superclasses nil direct-superclasses-p)
604     (direct-slots nil direct-slots-p)
605     direct-default-initargs
606     (predicate-name nil predicate-name-p))
607     (declare (ignore slot-names direct-default-initargs))
608     (if direct-superclasses-p
609     (setf (slot-value class 'direct-superclasses)
610     (or direct-superclasses
611     (setq direct-superclasses
612     (and (not (eq (class-name class) 'structure-object))
613     (list *the-class-structure-object*)))))
614     (setq direct-superclasses (slot-value class 'direct-superclasses)))
615     (let* ((name (class-name class))
616     (from-defclass-p (slot-value class 'from-defclass-p))
617     (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
618     (if direct-slots-p
619     (setf (slot-value class 'direct-slots)
620     (setq direct-slots
621 pmai 1.32 (mapcar (lambda (pl)
622     (when defstruct-p
623     (let* ((slot-name (getf pl :name))
624 gerd 1.44 (accessor
625 gerd 1.61 (symbolicate*
626 gerd 1.44 *package*
627     (if (symbol-package name)
628     (package-name (symbol-package name))
629     "")
630     "::" name " structure class " slot-name)))
631 pmai 1.32 (setq pl (list* :defstruct-accessor-symbol accessor
632     pl))))
633     (make-direct-slotd class pl))
634 ram 1.6 direct-slots)))
635     (setq direct-slots (slot-value class 'direct-slots)))
636 gerd 1.58 (if defstruct-p
637     (let* ((include (car (slot-value class 'direct-superclasses)))
638 gerd 1.61 (conc-name (symbolicate* *package*
639     (if (symbol-package name)
640     (package-name (symbol-package name))
641     "")
642     "::" name " structure class "))
643 gerd 1.58 ;;
644     ;; It's not possible to use a generalized name for the
645     ;; constructor function. It shouldn't matter though, I think,
646     ;; like for the slot names above, because this stuff is not
647     ;; supposed to be used by users directly.
648     (constructor
649 gerd 1.61 (symbolicate* *package* conc-name " constructor"))
650 gerd 1.58 (defstruct `(defstruct (,name
651     ,@(when include
652     `((:include ,(class-name include))))
653     (:predicate nil)
654     (:conc-name ,conc-name)
655     (:constructor ,constructor ()))
656     ;;
657     ;; Use a temporary unbound marker that lets
658     ;; SHARED-INITIALIZE recognize if a before-method
659     ;; has written to a slot.
660     ,@(mapcar (lambda (slot)
661     `(,(slot-definition-name slot)
662     '.unbound.))
663     direct-slots)))
664     (reader-names (mapcar (lambda (slotd)
665     (list 'slot-accessor name
666     (slot-definition-name slotd)
667     'reader))
668     direct-slots))
669     (writer-names (mapcar (lambda (slotd)
670     (list 'slot-accessor name
671     (slot-definition-name slotd)
672     'writer))
673     direct-slots))
674     (readers-init
675     (mapcar (lambda (slotd reader-name)
676     (let ((accessor
677     (slot-definition-defstruct-accessor-symbol slotd)))
678     `(defun ,reader-name (obj)
679     (declare (type ,name obj))
680     (,accessor obj))))
681     direct-slots reader-names))
682     (writers-init
683     (mapcar (lambda (slotd writer-name)
684     (let ((accessor
685     (slot-definition-defstruct-accessor-symbol slotd)))
686     `(defun ,writer-name (nv obj)
687     (declare (type ,name obj))
688     (setf (,accessor obj) nv))))
689     direct-slots writer-names))
690     (defstruct-form
691     `(progn
692     ,defstruct
693     ,@readers-init ,@writers-init)))
694     (unless (structure-type-p name) (eval defstruct-form))
695     (mapc (lambda (dslotd reader-name writer-name)
696     (let* ((reader (when (fboundp reader-name)
697     (gdefinition reader-name)))
698     (writer (when (fboundp writer-name)
699     (gdefinition writer-name))))
700     (setf (slot-value dslotd 'internal-reader-function) reader)
701     (setf (slot-value dslotd 'internal-writer-function) writer)))
702     direct-slots reader-names writer-names)
703     (setf (slot-value class 'defstruct-form) defstruct-form)
704     (setf (slot-value class 'defstruct-constructor) constructor))
705     ;;
706     ;; ALLOCATE-INSTANCE is supposed to work with structures
707     ;; defined with DEFSTRUCT.
708     (with-slots (defstruct-constructor) class
709     (setq defstruct-constructor
710     (make-defstruct-allocation-function class)))))
711     ;;
712 ram 1.6 (add-direct-subclasses class direct-superclasses)
713     (setf (slot-value class 'class-precedence-list)
714     (compute-class-precedence-list class))
715     (setf (slot-value class 'slots) (compute-slots class))
716 gerd 1.44 (let ((lclass (kernel::find-class (class-name class))))
717     (setf (kernel:%class-pcl-class lclass) class)
718     (setf (slot-value class 'wrapper) (kernel:%class-layout lclass)))
719 gerd 1.50 (setf (slot-value class 'finalized-p) t)
720 ram 1.6 (update-pv-table-cache-info class)
721     (setq predicate-name (if predicate-name-p
722     (setf (slot-value class 'predicate-name)
723     (car predicate-name))
724     (or (slot-value class 'predicate-name)
725     (setf (slot-value class 'predicate-name)
726     (make-class-predicate-name (class-name class))))))
727     (make-class-predicate class predicate-name)
728     (add-slot-accessors class direct-slots))
729 ram 1.4
730 gerd 1.58 ;;;
731     ;;; Return a closure for allocating an uninitialized structure
732     ;;; instance of class CLASS.
733     ;;;
734     (defun make-defstruct-allocation-function (class)
735     (let ((dd (get-structure-dd (class-name class))))
736     (lambda ()
737     (let ((instance (kernel::%make-instance (kernel::dd-length dd)))
738     (raw-index (kernel::dd-raw-index dd)))
739     (setf (kernel::%instance-layout instance)
740     (kernel::compiler-layout-or-lose (kernel::dd-name dd)))
741     (when raw-index
742 gerd 1.60 (setf (kernel::%instance-ref instance raw-index)
743     (make-array (kernel::dd-raw-length dd)
744     :element-type '(unsigned-byte 32))))
745 gerd 1.58 instance))))
746    
747 gerd 1.57 (defmethod direct-slot-definition-class ((class structure-class)
748     &rest initargs)
749 ram 1.6 (declare (ignore initargs))
750     (find-class 'structure-direct-slot-definition))
751    
752     (defmethod finalize-inheritance ((class structure-class))
753     nil) ; always finalized
754 wlott 1.1
755     (defun add-slot-accessors (class dslotds)
756     (fix-slot-accessors class dslotds 'add))
757    
758     (defun remove-slot-accessors (class dslotds)
759     (fix-slot-accessors class dslotds 'remove))
760    
761 gerd 1.44 (defun fix-slot-accessors (class dslotds add/remove)
762 ram 1.6 (flet ((fix (gfspec name r/w)
763 wlott 1.1 (let ((gf (ensure-generic-function gfspec)))
764     (case r/w
765     (r (if (eq add/remove 'add)
766 ram 1.6 (add-reader-method class gf name)
767 wlott 1.1 (remove-reader-method class gf)))
768     (w (if (eq add/remove 'add)
769 ram 1.6 (add-writer-method class gf name)
770 wlott 1.1 (remove-writer-method class gf)))))))
771     (dolist (dslotd dslotds)
772 ram 1.6 (let ((slot-name (slot-definition-name dslotd)))
773 gerd 1.44 (dolist (r (slot-definition-readers dslotd))
774     (fix r slot-name 'r))
775     (dolist (w (slot-definition-writers dslotd))
776     (fix w slot-name 'w))))))
777 wlott 1.1
778    
779     (defun add-direct-subclasses (class new)
780     (dolist (n new)
781     (unless (memq class (class-direct-subclasses class))
782     (add-direct-subclass n class))))
783    
784     (defun remove-direct-subclasses (class new)
785     (let ((old (class-direct-superclasses class)))
786     (dolist (o (set-difference old new))
787     (remove-direct-subclass o class))))
788    
789    
790     ;;;
791     ;;;
792     ;;;
793     (defmethod finalize-inheritance ((class std-class))
794     (update-class class t))
795 pmai 1.41
796     (defmethod finalize-inheritance ((class forward-referenced-class))
797     (simple-program-error
798 gerd 1.44 "~@<Forward-referenced classes cannot be finalized: ~A.~@:>"
799 pmai 1.41 class))
800 wlott 1.1
801    
802     ;;;
803 ram 1.4 ;;; Called by :after shared-initialize whenever a class is initialized or
804     ;;; reinitialized. The class may or may not be finalized.
805 wlott 1.1 ;;;
806 gerd 1.44 (defun update-class (class finalizep)
807 pmai 1.40 ;;
808 gerd 1.44 ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which
809     ;; makes the class finalized. When UPDATE-CLASS isn't called from
810     ;; FINALIZE-INHERITANCE, make sure that this finalization invokes
811     ;; FINALIZE-INHERITANCE as per AMOP. Note that we can't simply
812     ;; delay the finalization when CLASS has no forward referenced
813     ;; superclasses because that causes bootstrap problems.
814     (when (and (not (or finalizep (class-finalized-p class)))
815 pmai 1.40 (not (class-has-a-forward-referenced-superclass-p class)))
816     (finalize-inheritance class)
817     (return-from update-class))
818 gerd 1.44 ;;
819     (when (or finalizep
820     (class-finalized-p class)
821 ram 1.6 (not (class-has-a-forward-referenced-superclass-p class)))
822 gerd 1.47 (setf (find-class (class-name class)) class)
823 ram 1.4 (update-cpl class (compute-class-precedence-list class))
824 ram 1.6 (update-slots class (compute-slots class))
825 ram 1.4 (update-gfs-of-class class)
826     (update-inits class (compute-default-initargs class))
827 gerd 1.56 (update-shared-slot-values class)
828 gerd 1.44 (update-ctors 'finalize-inheritance :class class))
829     ;;
830 wlott 1.1 (unless finalizep
831 gerd 1.44 (dolist (sub (class-direct-subclasses class))
832     (update-class sub nil))))
833 gerd 1.56
834     ;;;
835     ;;; Set values of shared slots from initforms inherited from
836     ;;; superclasses, which can't be done before the cpl is known.
837     ;;;
838     (defun update-shared-slot-values (class)
839     (dolist (slot (class-slots class))
840     (when (eq (slot-definition-allocation slot) :class)
841     (let ((cell (assq (slot-definition-name slot) (class-slot-cells class))))
842 gerd 1.62 (when (and cell (eq +slot-unbound+ (cdr cell)))
843 gerd 1.56 (let ((initfn (slot-definition-initfunction slot)))
844     (when initfn
845     (setf (cdr cell) (funcall initfn)))))))))
846 wlott 1.1
847     (defun update-cpl (class cpl)
848 dtc 1.13 (if (class-finalized-p class)
849 gerd 1.55 (unless (and (equal (class-precedence-list class) cpl)
850     (loop for c in cpl never
851     (loop for s in (class-direct-slots c) thereis
852     (eq (slot-definition-allocation s)
853     :class))))
854 dtc 1.13 ;; Need to have the cpl setup before update-lisp-class-layout
855     ;; is called on CMUCL.
856     (setf (slot-value class 'class-precedence-list) cpl)
857     (force-cache-flushes class))
858     (setf (slot-value class 'class-precedence-list) cpl))
859 ram 1.4 (update-class-can-precede-p cpl))
860 gerd 1.51
861 ram 1.4 (defun update-class-can-precede-p (cpl)
862 gerd 1.51 (loop for (class . rest) on cpl do
863     (with-slots (can-precede-list) class
864     (setq can-precede-list
865     (union rest can-precede-list :test #'eq)))))
866 ram 1.4
867     (defun class-can-precede-p (class1 class2)
868 ram 1.6 (member class2 (class-can-precede-list class1)))
869 ram 1.4
870 ram 1.6 (defun update-slots (class eslotds)
871 gerd 1.61 (collect ((instance-slots) (class-slots))
872 ram 1.4 (dolist (eslotd eslotds)
873 pmai 1.38 (ecase (slot-definition-allocation eslotd)
874 gerd 1.51 (:instance (instance-slots eslotd))
875     (:class (class-slots eslotd))))
876 ram 1.6 ;;
877     ;; If there is a change in the shape of the instances then the
878     ;; old class is now obsolete.
879     (let* ((nlayout (mapcar #'slot-definition-name
880 gerd 1.51 (sort (instance-slots) #'<
881 pmai 1.42 :key #'slot-definition-location)))
882 ram 1.6 (nslots (length nlayout))
883 gerd 1.51 (nwrapper-class-slots (compute-class-slots (class-slots)))
884     (owrapper (when (class-finalized-p class)
885     (class-wrapper class)))
886     (olayout (when owrapper
887     (wrapper-instance-slots-layout owrapper)))
888 ram 1.6 (nwrapper
889     (cond ((null owrapper)
890     (make-wrapper nslots class))
891 pmai 1.42 ;;
892     ;; We cannot reuse the old wrapper easily when it
893     ;; has class slot cells, even if these cells are
894 gerd 1.44 ;; EQUAL to the ones used in the new wrapper. The
895 pmai 1.42 ;; class slot cells of OWRAPPER may be referenced
896     ;; from caches, and if we don't change the wrapper,
897     ;; the caches won't notice that something has
898     ;; changed. We could do something here manually,
899     ;; but I don't think it's worth it.
900 ram 1.6 ((and (equal nlayout olayout)
901 pmai 1.42 (null (wrapper-class-slots owrapper)))
902 ram 1.6 owrapper)
903     (t
904     ;;
905     ;; This will initialize the new wrapper to have the same
906     ;; state as the old wrapper. We will then have to change
907     ;; that. This may seem like wasted work (it is), but the
908     ;; spec requires that we call make-instances-obsolete.
909     (make-instances-obsolete class)
910     (class-wrapper class)))))
911 pw 1.9
912 gerd 1.51 (with-slots (wrapper slots finalized-p) class
913 pw 1.9 (update-lisp-class-layout class nwrapper)
914 ram 1.6 (setf slots eslotds
915     (wrapper-instance-slots-layout nwrapper) nlayout
916     (wrapper-class-slots nwrapper) nwrapper-class-slots
917     (wrapper-no-of-instance-slots nwrapper) nslots
918 gerd 1.51 wrapper nwrapper
919     finalized-p t))
920 pw 1.9
921 ram 1.6 (unless (eq owrapper nwrapper)
922 gerd 1.44 (update-inline-access class)
923 gerd 1.46 (update-pv-table-cache-info class)
924     (maybe-update-standard-class-locations class)))))
925 wlott 1.1
926 ram 1.6 (defun compute-class-slots (eslotds)
927 pmai 1.32 (loop for eslotd in eslotds
928     for name = (slot-definition-name eslotd)
929 pmai 1.38 and class = (slot-definition-class eslotd)
930     collect (assoc name (class-slot-cells class))))
931 wlott 1.1
932 ram 1.4 (defun update-gfs-of-class (class)
933 ram 1.6 (when (and (class-finalized-p class)
934     (let ((cpl (class-precedence-list class)))
935     (or (member *the-class-slot-class* cpl)
936     (member *the-class-standard-effective-slot-definition* cpl))))
937 ram 1.4 (let ((gf-table (make-hash-table :test 'eq)))
938     (labels ((collect-gfs (class)
939     (dolist (gf (specializer-direct-generic-functions class))
940     (setf (gethash gf gf-table) t))
941     (mapc #'collect-gfs (class-direct-superclasses class))))
942     (collect-gfs class)
943 pmai 1.32 (maphash (lambda (gf ignore)
944     (declare (ignore ignore))
945     (update-gf-dfun class gf))
946 ram 1.4 gf-table)))))
947 wlott 1.1
948     (defun update-inits (class inits)
949 ram 1.6 (setf (plist-value class 'default-initargs) inits))
950 wlott 1.1
951    
952     ;;;
953     ;;;
954     ;;;
955 ram 1.4 (defmethod compute-default-initargs ((class slot-class))
956 gerd 1.54 (let ((initargs (loop for c in (class-precedence-list class)
957     append (class-direct-default-initargs c))))
958     (delete-duplicates initargs :test #'eq :key #'car :from-end t)))
959 wlott 1.1
960     ;;;
961     ;;; Protocols for constructing direct and effective slot definitions.
962     ;;;
963     ;;;
964     ;;;
965     ;;;
966 gerd 1.57 (defmethod direct-slot-definition-class ((class std-class) &rest initargs)
967 wlott 1.1 (declare (ignore initargs))
968     (find-class 'standard-direct-slot-definition))
969    
970 ram 1.6 (defun make-direct-slotd (class initargs)
971     (let ((initargs (list* :class class initargs)))
972 gerd 1.57 (apply #'make-instance
973     (apply #'direct-slot-definition-class class initargs)
974 gerd 1.44 initargs)))
975 ram 1.6
976 wlott 1.1 ;;;
977 gerd 1.44 ;;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
978     ;;; for each different slot name we find in our superclasses. Each
979     ;;; call receives the class and a list of the dslotds with that name.
980     ;;; The list is in most-specific-first order.
981     ;;;
982     (defmethod compute-slots ((class std-class))
983 gerd 1.61 (collect ((names/slots) (effective))
984 gerd 1.59 (dolist (c (reverse (class-precedence-list class)))
985     (dolist (slot (class-direct-slots c))
986     (let* ((name (slot-definition-name slot))
987     (entry (assq name (names/slots))))
988     (if entry
989     (push slot (cdr entry))
990     (names/slots (list name slot))))))
991     (dolist (e (names/slots) (effective))
992     (effective (compute-effective-slot-definition class (car e) (cdr e))))))
993 gerd 1.44
994 wlott 1.1 ;;;
995 gerd 1.44 ;;; These are the specified AMOP methods.
996 wlott 1.1 ;;;
997    
998 pmai 1.39 (defmethod compute-slots ((class standard-class))
999     (call-next-method))
1000 gerd 1.44
1001 pmai 1.39 (defmethod compute-slots :around ((class standard-class))
1002 gerd 1.44 (loop with slotds = (call-next-method) and location = -1
1003     for slot in slotds do
1004     (setf (slot-definition-location slot)
1005     (ecase (slot-definition-allocation slot)
1006     (:instance
1007     (incf location))
1008     (:class
1009     (let* ((name (slot-definition-name slot))
1010     (from-class (slot-definition-allocation-class slot))
1011     (cell (assq name (class-slot-cells from-class))))
1012     (assert (consp cell))
1013     cell))))
1014     (initialize-internal-slot-functions slot)
1015     finally
1016     (return slotds)))
1017 pmai 1.39
1018     (defmethod compute-slots ((class funcallable-standard-class))
1019     (call-next-method))
1020    
1021     (defmethod compute-slots :around ((class funcallable-standard-class))
1022 gerd 1.44 (labels (;;
1023     ;; Return a list of the names of instance slots in SLOTDS.
1024     (instance-slot-names (slotds)
1025     (loop for e in slotds
1026     when (eq (slot-definition-allocation e) :instance)
1027     collect (slot-definition-name e)))
1028     ;;
1029 pmai 1.39 ;; This sorts slots so that slots of classes later in the CPL
1030 gerd 1.44 ;; come before slots of other classes. This is crucial for
1031     ;; funcallable instances because it ensures that the slots of
1032     ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
1033     ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
1034     ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
1035     ;; a funcallable instance.
1036 pmai 1.39 (compute-layout (eslotds)
1037 gerd 1.44 (loop with first = ()
1038     with names = (instance-slot-names eslotds)
1039     for class in (reverse (class-precedence-list class)) do
1040     (loop for ss in (class-slots class)
1041     as name = (slot-definition-name ss)
1042     when (member name names) do
1043     (push name first)
1044     (setq names (delete name names)))
1045     finally (return (nreverse (nconc names first))))))
1046     ;;
1047 pmai 1.39 (let ((all-slotds (call-next-method))
1048     (instance-slots ())
1049     (class-slots ()))
1050 gerd 1.44 (loop for slotd in all-slotds do
1051     (ecase (slot-definition-allocation slotd)
1052     (:instance (push slotd instance-slots))
1053     (:class (push slotd class-slots))))
1054     (loop with layout = (compute-layout instance-slots)
1055     for slotd in instance-slots do
1056     (setf (slot-definition-location slotd)
1057     (position (slot-definition-name slotd) layout))
1058     (initialize-internal-slot-functions slotd))
1059     (loop for slotd in class-slots
1060     as name = (slot-definition-name slotd)
1061     as from-class = (slot-definition-allocation-class slotd) do
1062     (setf (slot-definition-location slotd)
1063     (assoc name (class-slot-cells from-class)))
1064     (assert (consp (slot-definition-location slotd)))
1065     (initialize-internal-slot-functions slotd))
1066 pmai 1.39 all-slotds)))
1067 ram 1.4
1068 ram 1.6 (defmethod compute-slots ((class structure-class))
1069 pmai 1.32 (mapcan (lambda (superclass)
1070     (mapcar (lambda (dslotd)
1071 gerd 1.52 (compute-effective-slot-definition
1072     class (slot-definition-name dslotd) (list dslotd)))
1073 pmai 1.32 (class-direct-slots superclass)))
1074 ram 1.6 (reverse (slot-value class 'class-precedence-list))))
1075 ram 1.4
1076 ram 1.6 (defmethod compute-slots :around ((class structure-class))
1077     (let ((eslotds (call-next-method)))
1078     (mapc #'initialize-internal-slot-functions eslotds)
1079     eslotds))
1080    
1081 gerd 1.68 (defvar *allow-funny-slot-names* nil)
1082 gerd 1.66
1083     (defmethod initialize-internal-slot-functions :around
1084     ((slotd structure-effective-slot-definition))
1085 gerd 1.68 (let ((*allow-funny-slot-names* t))
1086 gerd 1.66 (call-next-method)))
1087    
1088 gerd 1.52 (defmethod compute-effective-slot-definition
1089     ((class slot-class) slot-name dslotds)
1090     (declare (ignore slot-name))
1091 wlott 1.1 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
1092 gerd 1.57 (class (apply #'effective-slot-definition-class class initargs)))
1093 ram 1.6 (apply #'make-instance class initargs)))
1094 wlott 1.1
1095 gerd 1.57 (defmethod effective-slot-definition-class ((class std-class) &rest initargs)
1096 wlott 1.1 (declare (ignore initargs))
1097 ram 1.6 (find-class 'standard-effective-slot-definition))
1098 wlott 1.1
1099 gerd 1.57 (defmethod effective-slot-definition-class ((class structure-class)
1100     &rest initargs)
1101 ram 1.6 (declare (ignore initargs))
1102     (find-class 'structure-effective-slot-definition))
1103    
1104 ram 1.4 (defmethod compute-effective-slot-definition-initargs
1105     ((class slot-class) direct-slotds)
1106 wlott 1.1 (let* ((name nil)
1107     (initfunction nil)
1108     (initform nil)
1109     (initargs nil)
1110     (allocation nil)
1111 pmai 1.39 (allocation-class nil)
1112 wlott 1.1 (type t)
1113     (namep nil)
1114     (initp nil)
1115 ram 1.6 (allocp nil))
1116 wlott 1.1
1117     (dolist (slotd direct-slotds)
1118     (when slotd
1119     (unless namep
1120 ram 1.4 (setq name (slot-definition-name slotd)
1121 wlott 1.1 namep t))
1122     (unless initp
1123 ram 1.4 (when (slot-definition-initfunction slotd)
1124 ram 1.6 (setq initform (slot-definition-initform slotd)
1125     initfunction (slot-definition-initfunction slotd)
1126 wlott 1.1 initp t)))
1127     (unless allocp
1128 ram 1.4 (setq allocation (slot-definition-allocation slotd)
1129 pmai 1.39 allocation-class (slot-definition-class slotd)
1130 wlott 1.1 allocp t))
1131 ram 1.4 (setq initargs (append (slot-definition-initargs slotd) initargs))
1132     (let ((slotd-type (slot-definition-type slotd)))
1133 pmai 1.32 (setq type (cond ((eq type t) slotd-type)
1134 ram 1.4 ((*subtypep type slotd-type) type)
1135 ram 1.6 (t `(and ,type ,slotd-type)))))))
1136 wlott 1.1 (list :name name
1137     :initform initform
1138     :initfunction initfunction
1139     :initargs initargs
1140     :allocation allocation
1141 pmai 1.39 :allocation-class allocation-class
1142 ram 1.4 :type type
1143 ram 1.6 :class class)))
1144 wlott 1.1
1145 ram 1.6 (defmethod compute-effective-slot-definition-initargs :around
1146     ((class structure-class) direct-slotds)
1147     (let ((slotd (car direct-slotds)))
1148 gerd 1.67 (list* :defstruct-accessor-symbol
1149     (slot-definition-defstruct-accessor-symbol slotd)
1150     :internal-reader-function
1151     (slot-definition-internal-reader-function slotd)
1152     :internal-writer-function
1153     (slot-definition-internal-writer-function slotd)
1154 ram 1.6 (call-next-method))))
1155 wlott 1.1
1156     ;;;
1157     ;;; NOTE: For bootstrapping considerations, these can't use make-instance
1158     ;;; to make the method object. They have to use make-a-method which
1159     ;;; is a specially bootstrapped mechanism for making standard methods.
1160     ;;;
1161 ram 1.6 (defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
1162     (declare (ignore direct-slot initargs))
1163     (find-class 'standard-reader-method))
1164 wlott 1.1
1165 ram 1.6 (defmethod add-reader-method ((class slot-class) generic-function slot-name)
1166     (add-method generic-function
1167     (make-a-method 'standard-reader-method
1168     ()
1169     (list (or (class-name class) 'object))
1170     (list class)
1171     (make-reader-method-function class slot-name)
1172     "automatically generated reader method"
1173     slot-name)))
1174 wlott 1.1
1175 ram 1.6 (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
1176 ram 1.5 (declare (ignore direct-slot initargs))
1177 ram 1.6 (find-class 'standard-writer-method))
1178 ram 1.5
1179 ram 1.6 (defmethod add-writer-method ((class slot-class) generic-function slot-name)
1180     (add-method generic-function
1181     (make-a-method 'standard-writer-method
1182     ()
1183     (list 'new-value (or (class-name class) 'object))
1184     (list *the-class-t* class)
1185     (make-writer-method-function class slot-name)
1186     "automatically generated writer method"
1187     slot-name)))
1188 ram 1.5
1189 ram 1.6 (defmethod add-boundp-method ((class slot-class) generic-function slot-name)
1190     (add-method generic-function
1191     (make-a-method 'standard-boundp-method
1192     ()
1193     (list (or (class-name class) 'object))
1194     (list class)
1195     (make-boundp-method-function class slot-name)
1196     "automatically generated boundp method"
1197     slot-name)))
1198 ram 1.5
1199 ram 1.4 (defmethod remove-reader-method ((class slot-class) generic-function)
1200 wlott 1.1 (let ((method (get-method generic-function () (list class) nil)))
1201 gerd 1.44 (when method
1202     (remove-method generic-function method))))
1203 wlott 1.1
1204 ram 1.4 (defmethod remove-writer-method ((class slot-class) generic-function)
1205 gerd 1.44 (let ((method (get-method generic-function ()
1206     (list *the-class-t* class) nil)))
1207     (when method
1208     (remove-method generic-function method))))
1209 wlott 1.1
1210 ram 1.4 (defmethod remove-boundp-method ((class slot-class) generic-function)
1211     (let ((method (get-method generic-function () (list class) nil)))
1212 gerd 1.44 (when method
1213     (remove-method generic-function method))))
1214 ram 1.4
1215 wlott 1.1
1216     ;;;
1217     ;;; make-reader-method-function and make-write-method function are NOT part of
1218     ;;; the standard protocol. They are however useful, PCL makes uses makes use
1219     ;;; of them internally and documents them for PCL users.
1220     ;;;
1221     ;;; *** This needs work to make type testing by the writer functions which
1222     ;;; *** do type testing faster. The idea would be to have one constructor
1223     ;;; *** for each possible type test. In order to do this it would be nice
1224     ;;; *** to have help from inform-type-system-about-class and friends.
1225     ;;;
1226     ;;; *** There is a subtle bug here which is going to have to be fixed.
1227     ;;; *** Namely, the simplistic use of the template has to be fixed. We
1228     ;;; *** have to give the optimize-slot-value method the user might have
1229     ;;; *** defined for this metclass a chance to run.
1230     ;;;
1231 ram 1.6 (defmethod make-reader-method-function ((class slot-class) slot-name)
1232     (make-std-reader-method-function (class-name class) slot-name))
1233 wlott 1.1
1234 ram 1.6 (defmethod make-writer-method-function ((class slot-class) slot-name)
1235     (make-std-writer-method-function (class-name class) slot-name))
1236 ram 1.5
1237 ram 1.6 (defmethod make-boundp-method-function ((class slot-class) slot-name)
1238     (make-std-boundp-method-function (class-name class) slot-name))
1239 ram 1.5
1240 wlott 1.1
1241     ;;;; inform-type-system-about-class
1242     ;;;
1243 pw 1.26 ;;; This is NOT part of the standard protocol. It is an internal mechanism
1244 wlott 1.1 ;;; which PCL uses to *try* and tell the type system about class definitions.
1245     ;;; In a more fully integrated implementation of CLOS, the type system would
1246     ;;; know about class objects and class names in a more fundamental way and
1247     ;;; the mechanism used to inform the type system about new classes would be
1248     ;;; different.
1249     ;;;
1250     (defmethod inform-type-system-about-class ((class std-class) name)
1251 pw 1.26 ;; Maybe add skeleton lisp:standard-class to avoid undefined-function
1252     ;; compiler warnings. Not otherwise needed in this implementation.
1253 gerd 1.44 (inform-type-system-about-std-class name)
1254     (set-class-translation class name))
1255    
1256     (defmethod inform-type-system-about-class ((class funcallable-standard-class)
1257     name)
1258     (set-class-translation class name))
1259 pw 1.26
1260 gerd 1.44 (defmethod inform-type-system-about-class ((class structure-class) name)
1261     (set-class-translation class name))
1262    
1263     (defmethod inform-type-system-about-class ((class condition-class) name)
1264     (set-class-translation class name))
1265 pw 1.26
1266 gerd 1.50 (defmethod inform-type-system-about-class ((class forward-referenced-class)
1267     name)
1268     (inform-type-system-about-std-class name)
1269     (set-class-translation class name))
1270    
1271 wlott 1.1
1272     (defmethod compatible-meta-class-change-p (class proto-new-class)
1273     (eq (class-of class) (class-of proto-new-class)))
1274    
1275 ram 1.4 (defmethod validate-superclass ((class class) (new-super class))
1276     (or (eq new-super *the-class-t*)
1277     (eq (class-of class) (class-of new-super))))
1278 wlott 1.1
1279 dtc 1.16 (defmethod validate-superclass ((class standard-class) (new-super std-class))
1280     (let ((new-super-meta-class (class-of new-super)))
1281     (or (eq new-super-meta-class *the-class-std-class*)
1282     (eq (class-of class) new-super-meta-class))))
1283 ram 1.4
1284 wlott 1.1
1285     ;;;
1286 pmai 1.37 ;;; Force the flushing of caches by creating a new wrapper for CLASS,
1287     ;;; if necessary.
1288 wlott 1.1 ;;;
1289 pmai 1.37 ;;; If the LAYOUT-INVALID slot of CLASS's wrapper is
1290     ;;;
1291     ;;; -- (:FLUSH <new wrapper>) or (:OBSOLETE <new wrapper>), there's
1292     ;;; nothing to do. The new wrapper has already been created.
1293     ;;;
1294     ;;; -- :INVALID, then it has been set to that value by a previous
1295     ;;; call to REGISTER-LAYOUT for a superclass S of CLASS; S's
1296     ;;; wrapper has been invalidated together with its subclasses. In
1297     ;;; this case, CLASS's caches must obviously be flushed, too, like
1298     ;;; S's. So, make a new wrapper for CLASS, and translate kernel's
1299     ;;; :INVALID to PCL (:FLUSH <new wrapper>). UPDATE-SLOTS can later
1300     ;;; decide if it wants to make this (:OBSOLETE ...).
1301     ;;;
1302     ;;; -- NIL, then the wrapper is still valid, in which case we do
1303     ;;; the same as for :INVALID, but for the obviously slightly
1304     ;;; different reason.
1305 wlott 1.1 ;;;
1306     (defun force-cache-flushes (class)
1307 pmai 1.37 (let* ((owrapper (class-wrapper class)))
1308     (when (or (not (invalid-wrapper-p owrapper))
1309     (eq :invalid (kernel:layout-invalid owrapper)))
1310 ram 1.6 (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1311     class)))
1312 wlott 1.1 (setf (wrapper-instance-slots-layout nwrapper)
1313     (wrapper-instance-slots-layout owrapper))
1314     (setf (wrapper-class-slots nwrapper)
1315     (wrapper-class-slots owrapper))
1316 pmai 1.34 (with-pcl-lock
1317 pw 1.9 (update-lisp-class-layout class nwrapper)
1318 wlott 1.1 (setf (slot-value class 'wrapper) nwrapper)
1319 pmai 1.32 (invalidate-wrapper owrapper :flush nwrapper))))))
1320 wlott 1.1
1321     (defun flush-cache-trap (owrapper nwrapper instance)
1322     (declare (ignore owrapper))
1323 gerd 1.44 (cond ((std-instance-p instance)
1324     (setf (std-instance-wrapper instance) nwrapper))
1325     ((fsc-instance-p instance)
1326     (setf (fsc-instance-wrapper instance) nwrapper))
1327     (t
1328     (internal-error "Internal error."))))
1329 wlott 1.1
1330    
1331     ;;;
1332     ;;; make-instances-obsolete can be called by user code. It will cause the
1333     ;;; next access to the instance (as defined in 88-002R) to trap through the
1334     ;;; update-instance-for-redefined-class mechanism.
1335     ;;;
1336     (defmethod make-instances-obsolete ((class std-class))
1337 ram 1.6 (let* ((owrapper (class-wrapper class))
1338     (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1339     class)))
1340 wlott 1.1 (setf (wrapper-instance-slots-layout nwrapper)
1341     (wrapper-instance-slots-layout owrapper))
1342     (setf (wrapper-class-slots nwrapper)
1343     (wrapper-class-slots owrapper))
1344 pmai 1.34 (with-pcl-lock
1345 pw 1.9 (update-lisp-class-layout class nwrapper)
1346 wlott 1.1 (setf (slot-value class 'wrapper) nwrapper)
1347 pmai 1.32 (invalidate-wrapper owrapper :obsolete nwrapper)
1348 ram 1.6 class)))
1349 wlott 1.1
1350     (defmethod make-instances-obsolete ((class symbol))
1351     (make-instances-obsolete (find-class class)))
1352    
1353    
1354     ;;;
1355     ;;; obsolete-instance-trap is the internal trap that is called when we see
1356     ;;; an obsolete instance. The times when it is called are:
1357     ;;; - when the instance is involved in method lookup
1358     ;;; - when attempting to access a slot of an instance
1359     ;;;
1360     ;;; It is not called by class-of, wrapper-of, or any of the low-level instance
1361     ;;; access macros.
1362     ;;;
1363     ;;; Of course these times when it is called are an internal implementation
1364     ;;; detail of PCL and are not part of the documented description of when the
1365     ;;; obsolete instance update happens. The documented description is as it
1366     ;;; appears in 88-002R.
1367     ;;;
1368     ;;; This has to return the new wrapper, so it counts on all the methods on
1369     ;;; obsolete-instance-trap-internal to return the new wrapper. It also does
1370     ;;; a little internal error checking to make sure that the traps are only
1371     ;;; happening when they should, and that the trap methods are computing
1372     ;;; apropriate new wrappers.
1373     ;;;
1374 pw 1.9
1375     ;;; obsolete-instance-trap might be called on structure instances
1376     ;;; after a structure is redefined. In most cases, obsolete-instance-trap
1377     ;;; will not be able to fix the old instance, so it must signal an
1378     ;;; error. The hard part of this is that the error system and debugger
1379     ;;; might cause obsolete-instance-trap to be called again, so in that
1380     ;;; case, we have to return some reasonable wrapper, instead.
1381    
1382     (defvar *in-obsolete-instance-trap* nil)
1383 gerd 1.44
1384 pw 1.9 (defvar *the-wrapper-of-structure-object*
1385     (class-wrapper (find-class 'structure-object)))
1386    
1387     (define-condition obsolete-structure (error)
1388     ((datum :reader obsolete-structure-datum :initarg :datum))
1389     (:report
1390     (lambda (condition stream)
1391     ;; Don't try to print the structure, since it probably
1392     ;; won't work.
1393 gerd 1.44 (format stream "~@<Obsolete structure error in ~S ~
1394     for a structure of type ~S.~@:>"
1395 pw 1.9 (conditions::condition-function-name condition)
1396     (type-of (obsolete-structure-datum condition))))))
1397    
1398     (defun obsolete-instance-trap (owrapper nwrapper instance)
1399 pw 1.25 (if (not (pcl-instance-p instance))
1400 pw 1.9 (if *in-obsolete-instance-trap*
1401     *the-wrapper-of-structure-object*
1402     (let ((*in-obsolete-instance-trap* t))
1403     (error 'obsolete-structure :datum instance)))
1404     (let* ((class (wrapper-class* nwrapper))
1405     (copy (allocate-instance class)) ;??? allocate-instance ???
1406     (olayout (wrapper-instance-slots-layout owrapper))
1407     (nlayout (wrapper-instance-slots-layout nwrapper))
1408     (oslots (get-slots instance))
1409     (nslots (get-slots copy))
1410     (oclass-slots (wrapper-class-slots owrapper))
1411     (added ())
1412     (discarded ())
1413     (plist ()))
1414     ;; local --> local transfer
1415     ;; local --> shared discard
1416     ;; local --> -- discard
1417     ;; shared --> local transfer
1418     ;; shared --> shared discard
1419     ;; shared --> -- discard
1420     ;; -- --> local add
1421     ;; -- --> shared --
1422     ;;
1423     ;; Go through all the old local slots.
1424 pmai 1.32 ;;
1425     (loop for name in olayout and opos from 0
1426     as npos = (posq name nlayout)
1427     if npos do
1428 gerd 1.44 (setf (slot-ref nslots npos)
1429     (slot-ref oslots opos))
1430 pmai 1.32 else do
1431     (push name discarded)
1432 gerd 1.44 (unless (eq (slot-ref oslots opos) +slot-unbound+)
1433 pmai 1.32 (setf (getf plist name)
1434 gerd 1.44 (slot-ref oslots opos))))
1435 pw 1.9 ;;
1436     ;; Go through all the old shared slots.
1437     ;;
1438 pmai 1.32 (loop for (name . val) in oclass-slots
1439     for npos = (posq name nlayout)
1440     if npos do
1441 gerd 1.44 (setf (slot-ref nslots npos) val)
1442 pmai 1.32 else do
1443     (push name discarded)
1444 pmai 1.35 (unless (eq val +slot-unbound+)
1445 pmai 1.32 (setf (getf plist name) val)))
1446 pw 1.9 ;;
1447     ;; Go through all the new local slots to compute the added slots.
1448     ;;
1449     (dolist (nlocal nlayout)
1450     (unless (or (memq nlocal olayout)
1451     (assq nlocal oclass-slots))
1452     (push nlocal added)))
1453 wlott 1.1
1454 pw 1.9 (swap-wrappers-and-slots instance copy)
1455 wlott 1.1
1456 pw 1.9 (update-instance-for-redefined-class instance
1457     added
1458     discarded
1459     plist)
1460     nwrapper)))
1461 wlott 1.1
1462    
1463     ;;;
1464     ;;;
1465     ;;;
1466 pmai 1.29 (defun change-class-internal (instance new-class initargs)
1467 ram 1.6 (let* ((old-class (class-of instance))
1468 pw 1.9 (copy (allocate-instance new-class))
1469     (new-wrapper (get-wrapper copy))
1470 ram 1.6 (old-wrapper (class-wrapper old-class))
1471     (old-layout (wrapper-instance-slots-layout old-wrapper))
1472     (new-layout (wrapper-instance-slots-layout new-wrapper))
1473     (old-slots (get-slots instance))
1474 pw 1.9 (new-slots (get-slots copy))
1475 ram 1.6 (old-class-slots (wrapper-class-slots old-wrapper)))
1476    
1477 wlott 1.1 ;;
1478     ;; "The values of local slots specified by both the class Cto and
1479     ;; Cfrom are retained. If such a local slot was unbound, it remains
1480     ;; unbound."
1481 pmai 1.32 ;;
1482     (loop for new-slot in new-layout and new-position from 0
1483     for old-position = (posq new-slot old-layout)
1484     when old-position do
1485 gerd 1.44 (setf (slot-ref new-slots new-position)
1486     (slot-ref old-slots old-position)))
1487 wlott 1.1 ;;
1488     ;; "The values of slots specified as shared in the class Cfrom and
1489     ;; as local in the class Cto are retained."
1490     ;;
1491 pmai 1.32 (loop for (name . val) in old-class-slots
1492     for new-position = (posq name new-layout)
1493     when new-position do
1494 gerd 1.44 (setf (slot-ref new-slots new-position) val))
1495 wlott 1.1
1496     ;; Make the copy point to the old instance's storage, and make the
1497     ;; old instance point to the new storage.
1498 pw 1.9 (swap-wrappers-and-slots instance copy)
1499 wlott 1.1
1500 pmai 1.29 (apply #'update-instance-for-different-class copy instance initargs)
1501 wlott 1.1 instance))
1502    
1503     (defmethod change-class ((instance standard-object)
1504 pmai 1.29 (new-class standard-class)
1505 gerd 1.60 &rest initargs &key)
1506 pmai 1.29 (change-class-internal instance new-class initargs))
1507 wlott 1.1
1508 dtc 1.15 (defmethod change-class ((instance funcallable-standard-object)
1509 pmai 1.29 (new-class funcallable-standard-class)
1510 gerd 1.60 &rest initargs &key)
1511 pmai 1.29 (change-class-internal instance new-class initargs))
1512 dtc 1.17
1513     (defmethod change-class ((instance standard-object)
1514 pmai 1.29 (new-class funcallable-standard-class)
1515 gerd 1.60 &rest initargs &key)
1516 pmai 1.29 (declare (ignore initargs))
1517 gerd 1.44 (error "~@<Can't change the class of ~S to ~S ~
1518     because it isn't already an instance with metaclass ~S.~@:>"
1519 dtc 1.17 instance new-class 'standard-class))
1520    
1521     (defmethod change-class ((instance funcallable-standard-object)
1522 pmai 1.29 (new-class standard-class)
1523 gerd 1.60 &rest initargs &key)
1524 pmai 1.29 (declare (ignore initargs))
1525 gerd 1.44 (error "~@<Can't change the class of ~S to ~S ~
1526     because it isn't already an instance with metaclass ~S.~@:>"
1527 dtc 1.17 instance new-class 'funcallable-standard-class))
1528 wlott 1.1
1529 gerd 1.60 (defmethod change-class ((instance t) (new-class-name symbol)
1530     &rest initargs &key)
1531 pmai 1.29 (apply #'change-class instance (find-class new-class-name) initargs))
1532 wlott 1.1
1533    
1534    
1535     ;;;
1536     ;;; The metaclass BUILT-IN-CLASS
1537     ;;;
1538     ;;; This metaclass is something of a weird creature. By this point, all
1539     ;;; instances of it which will exist have been created, and no instance
1540     ;;; is ever created by calling MAKE-INSTANCE.
1541     ;;;
1542     ;;; But, there are other parts of the protcol we must follow and those
1543     ;;; definitions appear here.
1544     ;;;
1545     (defmethod shared-initialize :before
1546     ((class built-in-class) slot-names &rest initargs)
1547 ram 1.5 (declare (ignore slot-names initargs))
1548 gerd 1.44 (error "Attempt to initialize or reinitialize a built-in class."))
1549 wlott 1.1
1550 ram 1.6 (defmethod class-direct-slots ((class built-in-class)) ())
1551     (defmethod class-slots ((class built-in-class)) ())
1552     (defmethod class-direct-default-initargs ((class built-in-class)) ())
1553     (defmethod class-default-initargs ((class built-in-class)) ())
1554    
1555 ram 1.4 (defmethod validate-superclass ((c class) (s built-in-class))
1556 gerd 1.44 (or (eq s *the-class-t*)
1557     (eq s *the-class-stream*)))
1558 wlott 1.1
1559 ram 1.4
1560 wlott 1.1
1561     ;;;
1562     ;;;
1563     ;;;
1564    
1565 gerd 1.44 (macrolet ((frob (method)
1566     `(defmethod ,method ((class forward-referenced-class))
1567     (declare (ignore class))
1568     ())))
1569     (frob class-direct-slots)
1570     (frob class-direct-default-initargs))
1571    
1572     (macrolet ((frob (method)
1573     `(defmethod ,method ((class forward-referenced-class))
1574     (error "~@<~S called for forward referenced class ~S.~@:>"
1575     ',method class))))
1576     (frob class-default-initargs)
1577     (frob class-precedence-list)
1578     (frob class-slots))
1579    
1580 ram 1.4 (defmethod validate-superclass ((c slot-class)
1581 dtc 1.16 (f forward-referenced-class))
1582 pmai 1.32 t)
1583 wlott 1.1
1584    
1585     ;;;
1586     ;;;
1587     ;;;
1588    
1589     (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
1590     (pushnew dependent (plist-value metaobject 'dependents)))
1591    
1592     (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
1593     (setf (plist-value metaobject 'dependents)
1594     (delete dependent (plist-value metaobject 'dependents))))
1595    
1596     (defmethod map-dependents ((metaobject dependent-update-mixin) function)
1597     (dolist (dependent (plist-value metaobject 'dependents))
1598 ram 1.2 (funcall function dependent)))
1599 ram 1.4
1600 gerd 1.44
1601     ;;;
1602     ;;; Conditions
1603     ;;;
1604 gerd 1.45 (defmethod class-default-initargs ((class condition-class)) ())
1605     (defmethod class-direct-default-initargs ((class condition-class)) ())
1606    
1607 gerd 1.44 (defmethod shared-initialize :after ((class condition-class) slot-names
1608 gerd 1.63 &key direct-slots direct-superclasses)
1609 gerd 1.44 (declare (ignore slot-names))
1610     (let ((kernel-class (kernel::find-class (class-name class))))
1611     (with-slots (wrapper class-precedence-list prototype predicate-name
1612     (direct-supers direct-superclasses))
1613     class
1614 gerd 1.63 (setf (slot-value class 'direct-slots)
1615     (mapcar (lambda (pl) (make-direct-slotd class pl))
1616     direct-slots))
1617 gerd 1.50 (setf (slot-value class 'finalized-p) t)
1618 gerd 1.44 (setf (kernel:%class-pcl-class kernel-class) class)
1619     (setq direct-supers direct-superclasses)
1620     (setq wrapper (kernel:%class-layout kernel-class))
1621     (setq class-precedence-list (compute-class-precedence-list class))
1622     (add-direct-subclasses class direct-superclasses)
1623     (setq predicate-name (make-class-predicate-name (class-name class)))
1624 gerd 1.63 (make-class-predicate class predicate-name)
1625 gerd 1.65 (setf (slot-value class 'slots) (compute-slots class))))
1626     ;;
1627     ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
1628     ;; override condition accessors with generic functions. We do this
1629     ;; differently.
1630     (update-pv-table-cache-info class))
1631 gerd 1.44
1632 gerd 1.63 (defmethod direct-slot-definition-class
1633     ((class condition-class) &rest initargs)
1634     (declare (ignore initargs))
1635     (find-class 'condition-direct-slot-definition))
1636    
1637     (defmethod effective-slot-definition-class
1638     ((class condition-class) &rest initargs)
1639     (declare (ignore initargs))
1640     (find-class 'condition-effective-slot-definition))
1641    
1642     (defmethod finalize-inheritance ((class condition-class))
1643     nil)
1644 gerd 1.64
1645     (defmethod compute-effective-slot-definition
1646     ((class condition-class) slot-name dslotds)
1647     (let ((slotd (call-next-method)))
1648     (setf (slot-definition-reader-function slotd)
1649     (lambda (x)
1650     (handler-case
1651     (conditions::condition-reader-function x slot-name)
1652 gerd 1.70 (error () (values (slot-unbound class x slot-name))))))
1653 gerd 1.64 (setf (slot-definition-writer-function slotd)
1654     (lambda (v x)
1655     (conditions::condition-writer-function x v slot-name)))
1656     (setf (slot-definition-boundp-function slotd)
1657     (lambda (x)
1658     (multiple-value-bind (v c)
1659     (ignore-errors
1660     (conditions::condition-reader-function x slot-name))
1661     (declare (ignore v))
1662     (null c))))
1663     slotd))
1664 gerd 1.63
1665     (defmethod compute-slots ((class condition-class))
1666     (mapcan (lambda (superclass)
1667     (mapcar (lambda (dslotd)
1668     (compute-effective-slot-definition
1669     class (slot-definition-name dslotd) (list dslotd)))
1670     (class-direct-slots superclass)))
1671     (reverse (slot-value class 'class-precedence-list))))
1672    
1673 gerd 1.65 (defmethod compute-slots :around ((class condition-class))
1674     (let ((eslotds (call-next-method)))
1675     (mapc #'initialize-internal-slot-functions eslotds)
1676     eslotds))

  ViewVC Help
Powered by ViewVC 1.1.5