/[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.82.4.2 - (hide annotations)
Mon Mar 16 21:10:56 2009 UTC (5 years, 1 month ago) by rtoy
Branch: unicode-utf16-branch
CVS Tags: unicode-utf16-sync-label-2009-03-16, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25
Changes since 1.82.4.1: +1 -3 lines
Sync to CVS HEAD, tag label-2009-03-16.

But don't sync Config.FreeBSD_gencgc, Config.x86_freebsd,
FreeBSD-os.c, and FreeBSD-os.h.  Let Alex sync those later.

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

  ViewVC Help
Powered by ViewVC 1.1.5