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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.1.1.1  
changed lines
  Added in v.1.85

  ViewVC Help
Powered by ViewVC 1.1.5