/[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.57 - (hide annotations)
Tue Apr 29 10:33:51 2003 UTC (10 years, 11 months ago) by gerd
Branch: MAIN
Changes since 1.56: +10 -7 lines
	Make DIRECT-SLOT-DEFINITION-CLASS and EFFECTIVE-SLOT-DEFINITION-CLASS
	AMOP compliant.  From Kevin Rosenberg on cmucl-imp 2003-04-29.

	* src/pcl/std-class.lisp (direct-slot-definition-class):
	(effective-slot-definition-class): Change methods accordingly.
	(make-direct-slotd): Apply direct-slot-definition-class to
	initargs instead of funcalling it.
	(compute-effective-slot-definition): Likewise for
	effective-slot-definition-class.

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

  ViewVC Help
Powered by ViewVC 1.1.5