/[gcl]/gcl/pcl/gcl_pcl_std_class.lisp
ViewVC logotype

Diff of /gcl/pcl/gcl_pcl_std_class.lisp

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

revision 1.1 by camm, Fri May 6 21:56:56 2005 UTC revision 1.2 by camm, Sat May 7 02:52:30 2005 UTC
# Line 0  Line 1 
1    ;;;-*-Mode:LISP; Package:PCL; Base:10; Syntax:Common-lisp -*-
2    ;;;
3    ;;; *************************************************************************
4    ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
5    ;;; All rights reserved.
6    ;;;
7    ;;; Use and copying of this software and preparation of derivative works
8    ;;; based upon this software are permitted.  Any distribution of this
9    ;;; software or derivative works must comply with all applicable United
10    ;;; States export control laws.
11    ;;;
12    ;;; This software is made available AS IS, and Xerox Corporation makes no
13    ;;; warranty about the software, its performance or its conformity to any
14    ;;; specification.
15    ;;;
16    ;;; Any person obtaining a copy of this software is requested to send their
17    ;;; name and post office or electronic mail address to:
18    ;;;   CommonLoops Coordinator
19    ;;;   Xerox PARC
20    ;;;   3333 Coyote Hill Rd.
21    ;;;   Palo Alto, CA 94304
22    ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
23    ;;;
24    ;;; Suggestions, comments and requests for improvements are also welcome.
25    ;;; *************************************************************************
26    ;;;
27    
28    (in-package :pcl)
29    
30    (defmethod slot-accessor-function ((slotd effective-slot-definition) type)
31      (ecase type
32        (reader (slot-definition-reader-function slotd))
33        (writer (slot-definition-writer-function slotd))
34        (boundp (slot-definition-boundp-function slotd))))
35    
36    (defmethod (setf slot-accessor-function) (function
37                                              (slotd effective-slot-definition) type)
38      (ecase type
39        (reader (setf (slot-definition-reader-function slotd) function))
40        (writer (setf (slot-definition-writer-function slotd) function))
41        (boundp (setf (slot-definition-boundp-function slotd) function))))
42    
43    (defconstant *slotd-reader-function-std-p* 1)
44    (defconstant *slotd-writer-function-std-p* 2)
45    (defconstant *slotd-boundp-function-std-p* 4)
46    (defconstant *slotd-all-function-std-p* 7)
47    
48    (defmethod slot-accessor-std-p ((slotd effective-slot-definition) type)
49      (let ((flags (slot-value slotd 'accessor-flags)))
50        (declare (type fixnum flags))
51        (if (eq type 'all)
52            (eql *slotd-all-function-std-p* flags)
53            (let ((mask (ecase type
54                          (reader *slotd-reader-function-std-p*)
55                          (writer *slotd-writer-function-std-p*)
56                          (boundp *slotd-boundp-function-std-p*))))
57              (declare (type fixnum mask))
58              (not (zerop (the fixnum (logand mask flags))))))))
59    
60    (defmethod (setf slot-accessor-std-p) (value (slotd effective-slot-definition) type)
61      (let ((mask (ecase type
62                    (reader *slotd-reader-function-std-p*)
63                    (writer *slotd-writer-function-std-p*)
64                    (boundp *slotd-boundp-function-std-p*)))
65            (flags (slot-value slotd 'accessor-flags)))
66        (declare (type fixnum mask flags))
67        (setf (slot-value slotd 'accessor-flags)
68              (if value
69                  (the fixnum (logior mask flags))
70                  (the fixnum (logand (the fixnum (lognot mask)) flags)))))
71      value)
72    
73    (defmethod initialize-internal-slot-functions ((slotd effective-slot-definition))
74      (let* ((name (slot-value slotd 'name))
75             (class (slot-value slotd 'class)))
76        (let ((table (or (gethash name *name->class->slotd-table*)
77                         (setf (gethash name *name->class->slotd-table*)
78                               (make-hash-table :test 'eq :size 5)))))
79          (setf (gethash class table) slotd))
80        (dolist (type '(reader writer boundp))
81          (let* ((gf-name (ecase type
82                                  (reader 'slot-value-using-class)
83                                  (writer '(setf slot-value-using-class))
84                                  (boundp 'slot-boundp-using-class)))
85                 (gf (gdefinition gf-name)))
86            (compute-slot-accessor-info slotd type gf)))
87        (initialize-internal-slot-gfs name)))
88    
89    (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf)
90      (let* ((name (slot-value slotd 'name))
91             (class (slot-value slotd 'class))
92             (old-slotd (find-slot-definition class name))
93             (old-std-p (and old-slotd (slot-accessor-std-p old-slotd 'all))))
94        (multiple-value-bind (function std-p)
95            (if (eq *boot-state* 'complete)
96                (get-accessor-method-function gf type class slotd)
97                (get-optimized-std-accessor-method-function class slotd type))
98          #+kcl (si:turbo-closure function)
99          (setf (slot-accessor-std-p slotd type) std-p)
100          (setf (slot-accessor-function slotd type) function))
101        (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
102          (push (cons class name) *pv-table-cache-update-info*))))
103    
104    (defmethod slot-definition-allocation ((slotd structure-slot-definition))
105      :instance)
106    
107    
108    
109    (defmethod shared-initialize :after ((object documentation-mixin)
110                                         slot-names
111                                         &key (documentation nil documentation-p))
112      (declare (ignore slot-names))
113      (when documentation-p
114        (setf (plist-value object 'documentation) documentation)))
115    
116    (defmethod documentation (object &optional doc-type)
117      (lisp:documentation object doc-type))
118    
119    (defmethod (setf documentation) (new-value object &optional doc-type)
120      (declare (ignore new-value doc-type))
121      (error "Can't change the documentation of ~S." object))
122    
123    
124    (defmethod documentation ((object documentation-mixin) &optional doc-type)
125      (declare (ignore doc-type))
126      (plist-value object 'documentation))
127    
128    (defmethod (setf documentation) (new-value (object documentation-mixin) &optional doc-type)
129      (declare (ignore doc-type))
130      (setf (plist-value object 'documentation) new-value))
131    
132    
133    (defmethod documentation ((slotd standard-slot-definition) &optional doc-type)
134      (declare (ignore doc-type))
135      (slot-value slotd 'documentation))
136    
137    (defmethod (setf documentation) (new-value (slotd standard-slot-definition) &optional doc-type)
138      (declare (ignore doc-type))
139      (setf (slot-value slotd 'documentation) new-value))
140    
141    
142    ;;;
143    ;;; Various class accessors that are a little more complicated than can be
144    ;;; done with automatically generated reader methods.
145    ;;;
146    (defmethod class-finalized-p ((class pcl-class))
147      (with-slots (wrapper) class
148        (not (null wrapper))))
149    
150    (defmethod class-prototype ((class std-class))
151      (with-slots (prototype) class
152        (or prototype (setq prototype (allocate-instance class)))))
153    
154    (defmethod class-prototype ((class structure-class))
155      (with-slots (prototype wrapper defstruct-constructor) class
156        (or prototype
157            (setq prototype
158                  (if #-new-kcl-wrapper defstruct-constructor #+new-kcl-wrapper nil
159                      (allocate-instance class)
160                      (allocate-standard-instance wrapper))))))
161    
162    (defmethod class-direct-default-initargs ((class slot-class))
163      (plist-value class 'direct-default-initargs))
164    
165    (defmethod class-default-initargs ((class slot-class))
166      (plist-value class 'default-initargs))
167    
168    (defmethod class-constructors ((class slot-class))
169      (plist-value class 'constructors))
170    
171    (defmethod class-slot-cells ((class std-class))
172      (plist-value class 'class-slot-cells))
173    
174    
175    ;;;
176    ;;; Class accessors that are even a little bit more complicated than those
177    ;;; above.  These have a protocol for updating them, we must implement that
178    ;;; protocol.
179    ;;;
180    
181    ;;;
182    ;;; Maintaining the direct subclasses backpointers.  The update methods are
183    ;;; here, the values are read by an automatically generated reader method.
184    ;;;
185    (defmethod add-direct-subclass ((class class) (subclass class))
186      (with-slots (direct-subclasses) class
187        (pushnew subclass direct-subclasses)
188        subclass))
189    
190    (defmethod remove-direct-subclass ((class class) (subclass class))
191      (with-slots (direct-subclasses) class
192        (setq direct-subclasses (remove subclass direct-subclasses))
193        subclass))
194    
195    ;;;
196    ;;; Maintaining the direct-methods and direct-generic-functions backpointers.
197    ;;;
198    ;;; There are four generic functions involved, each has one method for the
199    ;;; class case and another method for the damned EQL specializers. All of
200    ;;; these are specified methods and appear in their specified place in the
201    ;;; class graph.
202    ;;;
203    ;;;   ADD-DIRECT-METHOD
204    ;;;   REMOVE-DIRECT-METHOD
205    ;;;   SPECIALIZER-DIRECT-METHODS
206    ;;;   SPECIALIZER-DIRECT-GENERIC-FUNCTIONS
207    ;;;
208    ;;; In each case, we maintain one value which is a cons.  The car is the list
209    ;;; methods.  The cdr is a list of the generic functions.  The cdr is always
210    ;;; computed lazily.
211    ;;;
212    
213    (defmethod add-direct-method ((specializer class) (method method))
214      (with-slots (direct-methods) specializer
215        (setf (car direct-methods) (adjoin method (car direct-methods))     ;PUSH
216              (cdr direct-methods) ()))
217      method)
218    
219    (defmethod remove-direct-method ((specializer class) (method method))
220      (with-slots (direct-methods) specializer
221        (setf (car direct-methods) (remove method (car direct-methods))
222              (cdr direct-methods) ()))
223      method)
224    
225    (defmethod specializer-direct-methods ((specializer class))
226      (with-slots (direct-methods) specializer
227        (car direct-methods)))
228    
229    (defmethod specializer-direct-generic-functions ((specializer class))
230      (with-slots (direct-methods) specializer
231        (or (cdr direct-methods)
232            (setf (cdr direct-methods)
233                  (gathering1 (collecting-once)
234                    (dolist (m (car direct-methods))
235                      (gather1 (method-generic-function m))))))))
236    
237    
238    
239    ;;;
240    ;;; This hash table is used to store the direct methods and direct generic
241    ;;; functions of EQL specializers.  Each value in the table is the cons.
242    ;;;
243    (defvar *eql-specializer-methods* (make-hash-table :test #'eql))
244    (defvar *class-eq-specializer-methods* (make-hash-table :test #'eq))
245    
246    (defmethod specializer-method-table ((specializer eql-specializer))
247      *eql-specializer-methods*)
248    
249    (defmethod specializer-method-table ((specializer class-eq-specializer))
250      *class-eq-specializer-methods*)
251    
252    (defmethod add-direct-method ((specializer specializer-with-object) (method method))
253      (let* ((object (specializer-object specializer))
254             (table (specializer-method-table specializer))
255             (entry (gethash object table)))
256        (unless entry
257          (setq entry
258                (setf (gethash object table)
259                      (cons nil nil))))
260        (setf (car entry) (adjoin method (car entry))
261              (cdr entry) ())
262        method))
263    
264    (defmethod remove-direct-method ((specializer specializer-with-object) (method method))
265      (let* ((object (specializer-object specializer))
266             (entry (gethash object (specializer-method-table specializer))))
267        (when entry
268          (setf (car entry) (remove method (car entry))
269                (cdr entry) ()))
270        method))
271    
272    (defmethod specializer-direct-methods ((specializer specializer-with-object))  
273      (car (gethash (specializer-object specializer)
274                    (specializer-method-table specializer))))
275    
276    (defmethod specializer-direct-generic-functions ((specializer specializer-with-object))
277      (let* ((object (specializer-object specializer))
278             (entry (gethash object (specializer-method-table specializer))))
279        (when entry
280          (or (cdr entry)
281              (setf (cdr entry)
282                    (gathering1 (collecting-once)
283                      (dolist (m (car entry))
284                        (gather1 (method-generic-function m)))))))))
285    
286    (defun map-specializers (function)
287      (declare (type function function))
288      (map-all-classes #'(lambda (class)
289                           (funcall function (class-eq-specializer class))
290                           (funcall function class)))
291      (maphash #'(lambda (object methods)
292                   (declare (ignore methods))
293                   (intern-eql-specializer object))
294               *eql-specializer-methods*)
295      (maphash #'(lambda (object specl)
296                   (declare (ignore object))
297                   (funcall function specl))
298               *eql-specializer-table*)
299      nil)
300    
301    (defun map-all-generic-functions (function)
302      (declare (type function function))
303      (let ((all-generic-functions (make-hash-table :test 'eq)))
304        (map-specializers #'(lambda (specl)
305                              (dolist (gf (specializer-direct-generic-functions specl))
306                                (unless (gethash gf all-generic-functions)
307                                  (setf (gethash gf all-generic-functions) t)
308                                  (funcall function gf))))))
309      nil)
310    
311    (defmethod shared-initialize :after ((specl class-eq-specializer) slot-names &key)
312      (declare (ignore slot-names))
313      (setf (slot-value specl 'type) `(class-eq ,(specializer-class specl))))
314    
315    (defmethod shared-initialize :after ((specl eql-specializer) slot-names &key)
316      (declare (ignore slot-names))
317      (setf (slot-value specl 'type) `(eql ,(specializer-object specl))))
318    
319    
320    
321    (defun real-load-defclass (name metaclass-name supers slots other accessors)
322      (do-standard-defsetfs-for-defclass accessors)                 ;***
323      (let ((res (apply #'ensure-class name :metaclass metaclass-name
324                        :direct-superclasses supers
325                        :direct-slots slots
326                        :definition-source `((defclass ,name)
327                                             ,(load-truename))
328                        other)))
329        #+cmu17 (kernel:layout-class (class-wrapper res))
330        #-cmu17 res))
331    
332    (setf (gdefinition 'load-defclass) #'real-load-defclass)
333    
334    (defun ensure-class (name &rest all)
335      (apply #'ensure-class-using-class name (find-class name nil) all))
336    
337    (defmethod ensure-class-using-class (name (class null) &rest args &key)
338      (multiple-value-bind (meta initargs)
339          (ensure-class-values class args)
340        (inform-type-system-about-class (class-prototype meta) name);***
341        (setf class (apply #'make-instance meta :name name initargs)
342              (find-class name) class)
343        (inform-type-system-about-class class name)                 ;***
344        class))
345    
346    (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
347      (multiple-value-bind (meta initargs)
348          (ensure-class-values class args)
349        (unless (eq (class-of class) meta) (change-class class meta))
350        (apply #'reinitialize-instance class initargs)
351        (setf (find-class name) class)
352        (inform-type-system-about-class class name)                 ;***
353        class))
354    
355    (defmethod class-predicate-name ((class t))
356      'function-returning-nil)
357    
358    (defun ensure-class-values (class args)
359      (let* ((initargs (copy-list args))
360             (unsupplied (list 1))
361             (supplied-meta   (getf initargs :metaclass unsupplied))
362             (supplied-supers (getf initargs :direct-superclasses unsupplied))
363             (supplied-slots  (getf initargs :direct-slots unsupplied))
364             (meta
365              (cond ((neq supplied-meta unsupplied)
366                     (find-class supplied-meta))
367                    ((or (null class)
368                         (forward-referenced-class-p class))
369                     *the-class-standard-class*)
370                    (t
371                     (class-of class)))))  
372        (flet ((fix-super (s)
373                          (cond ((classp s) s)
374                                ((not (legal-class-name-p s))
375                                 (error "~S is not a class or a legal class name." s))
376                                (t
377                                 (or (find-class s nil)
378                                     (setf (find-class s)
379                                           (make-instance 'forward-referenced-class
380                                                          :name s)))))))      
381              ;;
382              ;; CLHS: signal PROGRAM-ERROR, if
383              ;; (a) there are any duplicate slot names
384              ;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or
385              ;; :DOCUMENTATION appears more than one in a single slot description.
386              (loop for (slot . more) on (getf initargs :direct-slots)
387                    for slot-name = (getf slot :name)
388                    if (some (lambda (s) (eq slot-name (getf s :name))) more) do
389                    (specific-error :invalid-form
390                                    "More than one direct slot with name ~S."
391                                    slot-name)
392                    else do
393                    (loop for (option value . more) on slot by #'cddr
394                          when (and (member option '(:allocation :type :initform
395                                                                 :documentation))
396                                    (not (eq unsupplied
397                                             (getf more option unsupplied)))) do
398                                             (specific-error :invalid-form
399                                                             "Duplicate slot option ~S for slot ~S."
400                                                             option slot-name)))
401              ;;
402              ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name
403              ;; appears more than once in :DEFAULT-INITARGS class option.
404              (loop for (initarg . more) on (getf initargs :direct-default-initargs)
405                    for name = (car initarg)
406                    when (some (lambda (a) (eq (car a) name)) more) do
407                    (specific-error :invalid-form
408                                    "Duplicate initialization argument ~
409                    name ~S in :default-initargs of class ~A."
410                                    name class))
411              ;;
412              (loop (unless (remf initargs :metaclass) (return)))
413              (loop (unless (remf initargs :direct-superclasses) (return)))
414              (loop (unless (remf initargs :direct-slots) (return)))
415              (values meta
416                      (list* :direct-superclasses
417                             (and (neq supplied-supers unsupplied)
418                                  (mapcar #'fix-super supplied-supers))
419                             :direct-slots
420                             (and (neq supplied-slots unsupplied) supplied-slots)
421                             initargs)))))
422    
423    
424    ;;;
425    ;;;
426    ;;;
427    #|| ; since it doesn't do anything
428    (defmethod shared-initialize :before ((class std-class)
429                                          slot-names
430                                          &key direct-superclasses)
431      (declare (ignore slot-names))
432      ;; *** error checking
433      )
434    ||#
435      
436    (defmethod shared-initialize :after
437               ((class std-class)
438                slot-names
439                &key (direct-superclasses nil direct-superclasses-p)
440                     (direct-slots nil direct-slots-p)
441                     (direct-default-initargs nil direct-default-initargs-p)
442                     (predicate-name nil predicate-name-p))
443      (declare (ignore slot-names))
444      (if direct-superclasses-p
445          (progn
446            (setq direct-superclasses (or direct-superclasses
447                                          (list *the-class-standard-object*)))
448            (dolist (superclass direct-superclasses)
449              (unless (validate-superclass class superclass)
450                (error "The class ~S was specified as a~%super-class of the class ~S;~%~
451                        but the meta-classes ~S and~%~S are incompatible.~%
452                        Define a method for ~S to avoid this error."
453                       superclass class (class-of superclass) (class-of class)
454                       'validate-superclass)))
455            (setf (slot-value class 'direct-superclasses) direct-superclasses))
456          (setq direct-superclasses (slot-value class 'direct-superclasses)))
457      (setq direct-slots
458            (if direct-slots-p
459                (setf (slot-value class 'direct-slots)
460                      (mapcar #'(lambda (pl) (make-direct-slotd class pl)) direct-slots))
461                (slot-value class 'direct-slots)))
462      (if direct-default-initargs-p
463          (setf (plist-value class 'direct-default-initargs) direct-default-initargs)
464          (setq direct-default-initargs (plist-value class 'direct-default-initargs)))
465      (setf (plist-value class 'class-slot-cells)
466            (gathering1 (collecting)
467              (dolist (dslotd direct-slots)
468                (when (eq (slot-definition-allocation dslotd) class)
469                  (let ((initfunction (slot-definition-initfunction dslotd)))
470                    (gather1 (cons (slot-definition-name dslotd)
471                                   (if initfunction
472                                       (funcall initfunction)
473                                       *slot-unbound*))))))))
474      (setq predicate-name (if predicate-name-p
475                               (setf (slot-value class 'predicate-name)
476                                     (car predicate-name))
477                               (or (slot-value class 'predicate-name)
478                                   (setf (slot-value class 'predicate-name)
479                                         (make-class-predicate-name (class-name class))))))
480      (add-direct-subclasses class direct-superclasses)
481      (update-class class nil)
482      (make-class-predicate class predicate-name)
483      (add-slot-accessors class direct-slots))
484    
485    (defmethod shared-initialize :before ((class class) slot-names &key name)
486      (declare (ignore slot-names name))
487      (setf (slot-value class 'type) `(class ,class))
488      (setf (slot-value class 'class-eq-specializer)
489            (make-instance 'class-eq-specializer :class class)))
490    
491    (defmethod reinitialize-instance :before ((class slot-class) &key)
492      (remove-direct-subclasses class (class-direct-superclasses class))
493      (remove-slot-accessors    class (class-direct-slots class)))
494    
495    (defmethod reinitialize-instance :after ((class slot-class)
496                                             &rest initargs
497                                             &key)
498      (map-dependents class
499                      #'(lambda (dependent)
500                          (apply #'update-dependent class dependent initargs))))
501    
502    (defmethod shared-initialize :after
503          ((class structure-class)
504           slot-names
505           &key (direct-superclasses nil direct-superclasses-p)
506                (direct-slots nil direct-slots-p)
507                direct-default-initargs
508                (predicate-name nil predicate-name-p))
509      (declare (ignore slot-names direct-default-initargs))
510      (if direct-superclasses-p
511          (setf (slot-value class 'direct-superclasses)
512                (or direct-superclasses
513                    (setq direct-superclasses
514                          (and (not (eq (class-name class) 'structure-object))
515                               (list *the-class-structure-object*)))))
516          (setq direct-superclasses (slot-value class 'direct-superclasses)))
517      (let* ((name (class-name class))
518             (from-defclass-p (slot-value class 'from-defclass-p))
519             (defstruct-p (or from-defclass-p (not (structure-type-p name)))))
520        (if direct-slots-p
521            (setf (slot-value class 'direct-slots)
522                  (setq direct-slots
523                        (mapcar #'(lambda (pl)
524                                    (when defstruct-p
525                                      (let* ((slot-name (getf pl :name))
526                                             (acc-name (format nil "~s structure class ~a"
527                                                               name slot-name))
528                                             (accessor (intern acc-name)))
529                                        (setq pl (list* :defstruct-accessor-symbol accessor
530                                                        pl))))
531                                    (make-direct-slotd class pl))
532                                direct-slots)))
533            (setq direct-slots (slot-value class 'direct-slots)))
534        (when defstruct-p
535          (let* ((include (car (slot-value class 'direct-superclasses)))
536                 (conc-name (intern (format nil "~s structure class " name)))
537                 (constructor (intern (format nil "~a constructor" conc-name)))
538                 (defstruct `(defstruct (,name
539                                          ,@(when include
540                                              `((:include ,(class-name include))))
541                                          (:print-function print-std-instance)
542                                          (:predicate nil)
543                                          (:conc-name ,conc-name)
544                                          (:constructor ,constructor ()))
545                               ,@(mapcar #'(lambda (slot)
546                                             `(,(slot-definition-name slot)
547                                               *slot-unbound*))
548                                         direct-slots)))
549                 (reader-names (mapcar #'(lambda (slotd)
550                                           (intern (format nil "~A~A reader" conc-name
551                                                           (slot-definition-name slotd))))
552                                       direct-slots))
553                 (writer-names (mapcar #'(lambda (slotd)
554                                           (intern (format nil "~A~A writer" conc-name
555                                                           (slot-definition-name slotd))))
556                                       direct-slots))
557                 (readers-init
558                  (mapcar #'(lambda (slotd reader-name)
559                              (let ((accessor
560                                     (slot-definition-defstruct-accessor-symbol slotd)))
561                                `(defun ,reader-name (obj)
562                                   (declare (type ,name obj))
563                                   (,accessor obj))))
564                          direct-slots reader-names))
565                 (writers-init
566                  (mapcar #'(lambda (slotd writer-name)
567                              (let ((accessor
568                                     (slot-definition-defstruct-accessor-symbol slotd)))
569                                `(defun ,writer-name (nv obj)
570                                   (declare (type ,name obj))
571                                   (setf (,accessor obj) nv))))
572                          direct-slots writer-names))
573                 (defstruct-form
574                   `(progn
575                      ,defstruct
576                      ,@readers-init ,@writers-init
577                      (declare-structure ',name nil nil))))
578            (unless (structure-type-p name) (eval defstruct-form))
579            (mapc #'(lambda (dslotd reader-name writer-name)
580                      (let* ((reader (gdefinition reader-name))
581                             (writer (when (gboundp writer-name)
582                                       (gdefinition writer-name))))
583                        (setf (slot-value dslotd 'internal-reader-function) reader)
584                        (setf (slot-value dslotd 'internal-writer-function) writer)))
585                  direct-slots reader-names writer-names)
586            (setf (slot-value class 'defstruct-form) defstruct-form)
587            (setf (slot-value class 'defstruct-constructor) constructor))))
588      (add-direct-subclasses class direct-superclasses)
589      (setf (slot-value class 'class-precedence-list)
590            (compute-class-precedence-list class))
591      (setf (slot-value class 'slots) (compute-slots class))
592      #-(or cmu17 new-kcl-wrapper)
593      (unless (slot-value class 'wrapper)
594        (setf (slot-value class 'wrapper) (make-wrapper 0 class)))
595      #+cmu17
596     (let ((lclass (lisp:find-class (class-name class))))
597        (setf (kernel:class-pcl-class lclass) class)
598        (setf (slot-value class 'wrapper) (kernel:class-layout lclass)))
599      #+new-kcl-wrapper
600      (let ((wrapper (get (class-name class) 'si::s-data)))
601        (setf (slot-value class 'wrapper) wrapper)
602        (setf (wrapper-class wrapper) class))
603      (update-pv-table-cache-info class)
604      (setq predicate-name (if predicate-name-p
605                               (setf (slot-value class 'predicate-name)
606                                     (car predicate-name))
607                               (or (slot-value class 'predicate-name)
608                                   (setf (slot-value class 'predicate-name)
609                                         (make-class-predicate-name (class-name class))))))
610      (make-class-predicate class predicate-name)
611      (add-slot-accessors class direct-slots))
612    
613    (defmethod direct-slot-definition-class ((class structure-class) initargs)
614      (declare (ignore initargs))
615      (find-class 'structure-direct-slot-definition))
616    
617    (defmethod finalize-inheritance ((class structure-class))
618      nil) ; always finalized
619    
620    (defun add-slot-accessors (class dslotds)
621      (fix-slot-accessors class dslotds 'add))
622    
623    (defun remove-slot-accessors (class dslotds)
624      (fix-slot-accessors class dslotds 'remove))
625    
626    (defun fix-slot-accessors (class dslotds add/remove)  
627      (flet ((fix (gfspec name r/w)
628               (let ((gf (ensure-generic-function gfspec)))
629                 (case r/w
630                   (r (if (eq add/remove 'add)
631                          (add-reader-method class gf name)
632                          (remove-reader-method class gf)))
633                   (w (if (eq add/remove 'add)
634                          (add-writer-method class gf name)
635                          (remove-writer-method class gf)))))))
636        (dolist (dslotd dslotds)
637          (let ((slot-name (slot-definition-name dslotd)))
638            (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r))
639            (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w))))))
640    
641    
642    (defun add-direct-subclasses (class new)
643      (dolist (n new)
644        (unless (memq class (class-direct-subclasses class))
645          (add-direct-subclass n class))))
646    
647    (defun remove-direct-subclasses (class new)
648      (let ((old (class-direct-superclasses class)))
649        (dolist (o (set-difference old new))
650          (remove-direct-subclass o class))))
651    
652    
653    ;;;
654    ;;;
655    ;;;
656    (defmethod finalize-inheritance ((class std-class))
657      (update-class class t))
658    
659    
660    (defun class-has-a-forward-referenced-superclass-p (class)
661      (or (forward-referenced-class-p class)
662          (some #'class-has-a-forward-referenced-superclass-p
663                (class-direct-superclasses class))))        
664          
665    ;;;
666    ;;; Called by :after shared-initialize whenever a class is initialized or
667    ;;; reinitialized.  The class may or may not be finalized.
668    ;;;
669    (defun update-class (class finalizep)  
670      (when (or finalizep (class-finalized-p class)
671                (not (class-has-a-forward-referenced-superclass-p class)))
672        (update-cpl class (compute-class-precedence-list class))
673        (update-slots class (compute-slots class))
674        (update-gfs-of-class class)
675        (update-inits class (compute-default-initargs class))
676        (update-make-instance-function-table class))
677      (unless finalizep
678        (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))
679    
680    (defun update-cpl (class cpl)
681      (when (class-finalized-p class)
682        (unless (equal (class-precedence-list class) cpl)
683          (force-cache-flushes class)))
684      (setf (slot-value class 'class-precedence-list) cpl)
685      (update-class-can-precede-p cpl))
686    
687    (defun update-class-can-precede-p (cpl)
688      (when cpl
689        (let ((first (car cpl)))
690          (dolist (c (cdr cpl))
691            (pushnew c (slot-value first 'can-precede-list))))
692        (update-class-can-precede-p (cdr cpl))))
693    
694    (defun class-can-precede-p (class1 class2)
695      (member class2 (class-can-precede-list class1)))
696    
697    (defun update-slots (class eslotds)
698      (let ((instance-slots ())
699            (class-slots    ()))
700        (dolist (eslotd eslotds)
701          (let ((alloc (slot-definition-allocation eslotd)))
702            (cond ((eq alloc :instance) (push eslotd instance-slots))
703                  ((classp alloc)       (push eslotd class-slots)))))
704        ;;
705        ;; If there is a change in the shape of the instances then the
706        ;; old class is now obsolete.
707        ;;
708        (let* ((nlayout (mapcar #'slot-definition-name
709                                (sort instance-slots #'< :key #'slot-definition-location)))
710               (nslots (length nlayout))
711               (nwrapper-class-slots (compute-class-slots class-slots))
712               (owrapper (class-wrapper class))
713               (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
714               (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
715               (nwrapper
716                (cond ((null owrapper)
717                       (make-wrapper nslots class))
718                      ((and (equal nlayout olayout)
719                            (not
720                             (iterate ((o (list-elements owrapper-class-slots))
721                                       (n (list-elements nwrapper-class-slots)))
722                                      (unless (eq (car o) (car n)) (return t)))))
723                       owrapper)
724                      (t
725                       ;;
726                       ;; This will initialize the new wrapper to have the same
727                       ;; state as the old wrapper.  We will then have to change
728                       ;; that.  This may seem like wasted work (it is), but the
729                       ;; spec requires that we call make-instances-obsolete.
730                       ;;
731                       (make-instances-obsolete class)
732                       (class-wrapper class)))))
733    
734          (with-slots (wrapper slots) class
735            #+new-kcl-wrapper
736            (setf (si::s-data-name nwrapper) (class-name class))
737            #+cmu17
738            (update-lisp-class-layout class nwrapper)
739            (setf slots eslotds
740                  (wrapper-instance-slots-layout nwrapper) nlayout
741                  (wrapper-class-slots nwrapper) nwrapper-class-slots
742                  (wrapper-no-of-instance-slots nwrapper) nslots
743                  wrapper nwrapper))
744    
745          (unless (eq owrapper nwrapper)
746            (update-pv-table-cache-info class)))))
747    
748    (defun compute-class-slots (eslotds)
749      (gathering1 (collecting)
750        (dolist (eslotd eslotds)
751          (gather1
752            (assoc (slot-definition-name eslotd)
753                   (class-slot-cells (slot-definition-allocation eslotd)))))))
754    
755    (defun compute-layout (cpl instance-eslotds)
756      (let* ((names
757               (gathering1 (collecting)
758                 (dolist (eslotd instance-eslotds)
759                   (when (eq (slot-definition-allocation eslotd) :instance)
760                     (gather1 (slot-definition-name eslotd))))))
761             (order ()))
762        (labels ((rwalk (tail)
763                   (when tail
764                     (rwalk (cdr tail))
765                     (dolist (ss (class-slots (car tail)))
766                       (let ((n (slot-definition-name ss)))
767                         (when (member n names)
768                           (setq order (cons n order)
769                                 names (remove n names))))))))
770          (rwalk (if (slot-boundp (car cpl) 'slots)
771                     cpl
772                     (cdr cpl)))
773          (reverse (append names order)))))
774    
775    (defun update-gfs-of-class (class)
776      (when (and (class-finalized-p class)
777                 (let ((cpl (class-precedence-list class)))
778                   (or (member *the-class-slot-class* cpl)
779                       (member *the-class-standard-effective-slot-definition* cpl))))
780        (let ((gf-table (make-hash-table :test 'eq)))
781          (labels ((collect-gfs (class)
782                     (dolist (gf (specializer-direct-generic-functions class))
783                       (setf (gethash gf gf-table) t))
784                     (mapc #'collect-gfs (class-direct-superclasses class))))
785            (collect-gfs class)
786            (maphash #'(lambda (gf ignore)
787                         (declare (ignore ignore))
788                         (update-gf-dfun class gf))
789                     gf-table)))))
790    
791    (defun update-inits (class inits)
792      (setf (plist-value class 'default-initargs) inits))
793    
794    
795    ;;;
796    ;;;
797    ;;;
798    (defmethod compute-default-initargs ((class slot-class))
799      (let ((cpl (class-precedence-list class))
800            (direct (class-direct-default-initargs class)))
801        (labels ((walk (tail)
802                   (if (null tail)
803                       nil
804                       (let ((c (pop tail)))
805                         (append (if (eq c class)
806                                     direct
807                                     (class-direct-default-initargs c))
808                                 (walk tail))))))
809          (let ((initargs (walk cpl)))
810            (delete-duplicates initargs :test #'eq :key #'car :from-end t)))))
811    
812    
813    ;;;
814    ;;; Protocols for constructing direct and effective slot definitions.
815    ;;;
816    ;;;
817    ;;;
818    ;;;
819    (defmethod direct-slot-definition-class ((class std-class) initargs)
820      (declare (ignore initargs))
821      (find-class 'standard-direct-slot-definition))
822    
823    (defun make-direct-slotd (class initargs)
824      (let ((initargs (list* :class class initargs)))
825        (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))
826    
827    ;;;
828    ;;;
829    ;;;
830    (defmethod compute-slots ((class std-class))
831      ;;
832      ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
833      ;; for each different slot name we find in our superclasses.  Each
834      ;; call receives the class and a list of the dslotds with that name.
835      ;; The list is in most-specific-first order.
836      ;;
837      (let ((name-dslotds-alist ()))
838        (dolist (c (class-precedence-list class))
839          (let ((dslotds (class-direct-slots c)))
840            (dolist (d dslotds)
841              (let* ((name (slot-definition-name d))
842                     (entry (assq name name-dslotds-alist)))
843                (if entry
844                    (push d (cdr entry))
845                    (push (list name d) name-dslotds-alist))))))
846        (mapcar #'(lambda (direct)
847                    (compute-effective-slot-definition class
848                                                       (nreverse (cdr direct))))
849                name-dslotds-alist)))
850    
851    (defmethod compute-slots :around ((class std-class))
852      (let ((eslotds (call-next-method))
853            (cpl (class-precedence-list class))
854            (instance-slots ())
855            (class-slots    ()))
856        (dolist (eslotd eslotds)
857          (let ((alloc (slot-definition-allocation eslotd)))
858            (cond ((eq alloc :instance) (push eslotd instance-slots))
859                  ((classp alloc)       (push eslotd class-slots)))))
860        (let ((nlayout (compute-layout cpl instance-slots)))
861          (dolist (eslotd instance-slots)
862            (setf (slot-definition-location eslotd)
863                  (position (slot-definition-name eslotd) nlayout))))
864        (dolist (eslotd class-slots)
865          (setf (slot-definition-location eslotd)
866                (assoc (slot-definition-name eslotd)
867                       (class-slot-cells (slot-definition-allocation eslotd)))))
868        (mapc #'initialize-internal-slot-functions eslotds)
869        eslotds))
870    
871    (defmethod compute-slots ((class structure-class))
872      (mapcan #'(lambda (superclass)
873                  (mapcar #'(lambda (dslotd)
874                              (compute-effective-slot-definition class
875                                                                 (list dslotd)))
876                          (class-direct-slots superclass)))
877              (reverse (slot-value class 'class-precedence-list))))
878    
879    (defmethod compute-slots :around ((class structure-class))
880      (let ((eslotds (call-next-method)))
881        (mapc #'initialize-internal-slot-functions eslotds)
882        eslotds))
883    
884    (defmethod compute-effective-slot-definition ((class slot-class) dslotds)
885      (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
886             (class (effective-slot-definition-class class initargs)))
887        (apply #'make-instance class initargs)))
888    
889    (defmethod effective-slot-definition-class ((class std-class) initargs)
890      (declare (ignore initargs))
891      (find-class 'standard-effective-slot-definition))
892    
893    (defmethod effective-slot-definition-class ((class structure-class) initargs)
894      (declare (ignore initargs))
895      (find-class 'structure-effective-slot-definition))
896    
897    (defmethod compute-effective-slot-definition-initargs
898        ((class slot-class) direct-slotds)
899      (let* ((name nil)
900             (initfunction nil)
901             (initform nil)
902             (initargs nil)
903             (allocation nil)
904             (type t)
905             (namep  nil)
906             (initp  nil)
907             (allocp nil))
908    
909        (dolist (slotd direct-slotds)
910          (when slotd
911            (unless namep
912              (setq name (slot-definition-name slotd)
913                    namep t))
914            (unless initp
915              (when (slot-definition-initfunction slotd)
916                (setq initform (slot-definition-initform slotd)
917                      initfunction (slot-definition-initfunction slotd)
918                      initp t)))
919            (unless allocp
920              (setq allocation (slot-definition-allocation slotd)
921                    allocp t))
922            (setq initargs (append (slot-definition-initargs slotd) initargs))
923            (let ((slotd-type (slot-definition-type slotd)))
924              (setq type (cond ((eq type 't) slotd-type)
925                               ((*subtypep type slotd-type) type)
926                               (t `(and ,type ,slotd-type)))))))
927        (list :name name
928              :initform initform
929              :initfunction initfunction
930              :initargs initargs
931              :allocation allocation
932              :type type
933              :class class)))
934    
935    (defmethod compute-effective-slot-definition-initargs :around
936        ((class structure-class) direct-slotds)
937      (let ((slotd (car direct-slotds)))
938        (list* :defstruct-accessor-symbol (slot-definition-defstruct-accessor-symbol slotd)
939               :internal-reader-function (slot-definition-internal-reader-function slotd)
940               :internal-writer-function (slot-definition-internal-writer-function slotd)
941               (call-next-method))))
942    
943    ;;;
944    ;;; NOTE: For bootstrapping considerations, these can't use make-instance
945    ;;;       to make the method object.  They have to use make-a-method which
946    ;;;       is a specially bootstrapped mechanism for making standard methods.
947    ;;;
948    (defmethod reader-method-class ((class slot-class) direct-slot &rest initargs)
949      (declare (ignore direct-slot initargs))
950      (find-class 'standard-reader-method))
951    
952    (defmethod add-reader-method ((class slot-class) generic-function slot-name)
953      (add-method generic-function
954                  (make-a-method 'standard-reader-method
955                                 ()
956                                 (list (or (class-name class) 'object))
957                                 (list class)
958                                 (make-reader-method-function class slot-name)
959                                 "automatically generated reader method"
960                                 slot-name)))
961    
962    (defmethod writer-method-class ((class slot-class) direct-slot &rest initargs)
963      (declare (ignore direct-slot initargs))
964      (find-class 'standard-writer-method))
965    
966    (defmethod add-writer-method ((class slot-class) generic-function slot-name)
967      (add-method generic-function
968                  (make-a-method 'standard-writer-method
969                                 ()
970                                 (list 'new-value (or (class-name class) 'object))
971                                 (list *the-class-t* class)
972                                 (make-writer-method-function class slot-name)
973                                 "automatically generated writer method"
974                                 slot-name)))
975    
976    (defmethod add-boundp-method ((class slot-class) generic-function slot-name)
977      (add-method generic-function
978                  (make-a-method 'standard-boundp-method
979                                 ()
980                                 (list (or (class-name class) 'object))
981                                 (list class)
982                                 (make-boundp-method-function class slot-name)
983                                 "automatically generated boundp method"
984                                 slot-name)))
985    
986    (defmethod remove-reader-method ((class slot-class) generic-function)
987      (let ((method (get-method generic-function () (list class) nil)))
988        (when method (remove-method generic-function method))))
989    
990    (defmethod remove-writer-method ((class slot-class) generic-function)
991      (let ((method
992              (get-method generic-function () (list *the-class-t* class) nil)))
993        (when method (remove-method generic-function method))))
994    
995    (defmethod remove-boundp-method ((class slot-class) generic-function)
996      (let ((method (get-method generic-function () (list class) nil)))
997        (when method (remove-method generic-function method))))
998    
999    
1000    ;;;
1001    ;;; make-reader-method-function and make-write-method function are NOT part of
1002    ;;; the standard protocol.  They are however useful, PCL makes uses makes use
1003    ;;; of them internally and documents them for PCL users.
1004    ;;;
1005    ;;; *** This needs work to make type testing by the writer functions which
1006    ;;; *** do type testing faster.  The idea would be to have one constructor
1007    ;;; *** for each possible type test.  In order to do this it would be nice
1008    ;;; *** to have help from inform-type-system-about-class and friends.
1009    ;;;
1010    ;;; *** There is a subtle bug here which is going to have to be fixed.
1011    ;;; *** Namely, the simplistic use of the template has to be fixed.  We
1012    ;;; *** have to give the optimize-slot-value method the user might have
1013    ;;; *** defined for this metclass a chance to run.
1014    ;;;
1015    (defmethod make-reader-method-function ((class slot-class) slot-name)
1016      (make-std-reader-method-function (class-name class) slot-name))
1017    
1018    (defmethod make-writer-method-function ((class slot-class) slot-name)
1019      (make-std-writer-method-function (class-name class) slot-name))
1020    
1021    (defmethod make-boundp-method-function ((class slot-class) slot-name)
1022      (make-std-boundp-method-function (class-name class) slot-name))
1023    
1024    
1025    ;;;; inform-type-system-about-class
1026    ;;;; make-type-predicate
1027    ;;;
1028    ;;; These are NOT part of the standard protocol.  They are internal mechanism
1029    ;;; which PCL uses to *try* and tell the type system about class definitions.
1030    ;;; In a more fully integrated implementation of CLOS, the type system would
1031    ;;; know about class objects and class names in a more fundamental way and
1032    ;;; the mechanism used to inform the type system about new classes would be
1033    ;;; different.
1034    ;;;
1035    (defmethod inform-type-system-about-class ((class std-class) name)
1036      (inform-type-system-about-std-class name))
1037    
1038    
1039    (defmethod compatible-meta-class-change-p (class proto-new-class)
1040      (eq (class-of class) (class-of proto-new-class)))
1041    
1042    (defmethod validate-superclass ((class class) (new-super class))
1043      (or (eq new-super *the-class-t*)
1044          (eq (class-of class) (class-of new-super))))
1045    
1046    
1047    
1048    ;;;
1049    ;;;
1050    ;;;
1051    (defun force-cache-flushes (class)
1052      (let* ((owrapper (class-wrapper class))
1053             (state (wrapper-state owrapper)))
1054        ;;
1055        ;; We only need to do something if the state is still T.  If the
1056        ;; state isn't T, it will be FLUSH or OBSOLETE, and both of those
1057        ;; will already be doing what we want.  In particular, we must be
1058        ;; sure we never change an OBSOLETE into a FLUSH since OBSOLETE
1059        ;; means do what FLUSH does and then some.
1060        ;;
1061        (when (eq state 't)
1062          (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1063                                        class)))
1064            (setf (wrapper-instance-slots-layout nwrapper)
1065                  (wrapper-instance-slots-layout owrapper))
1066            (setf (wrapper-class-slots nwrapper)
1067                  (wrapper-class-slots owrapper))
1068            (without-interrupts
1069              #+cmu17
1070              (update-lisp-class-layout class nwrapper)
1071              (setf (slot-value class 'wrapper) nwrapper)
1072              (invalidate-wrapper owrapper ':flush nwrapper))))))
1073    
1074    (defun flush-cache-trap (owrapper nwrapper instance)
1075      (declare (ignore owrapper))
1076      (set-wrapper instance nwrapper))
1077    
1078    
1079    
1080    ;;;
1081    ;;; make-instances-obsolete can be called by user code.  It will cause the
1082    ;;; next access to the instance (as defined in 88-002R) to trap through the
1083    ;;; update-instance-for-redefined-class mechanism.
1084    ;;;
1085    (defmethod make-instances-obsolete ((class std-class))
1086      (let* ((owrapper (class-wrapper class))
1087             (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
1088                                     class)))
1089          (setf (wrapper-instance-slots-layout nwrapper)
1090                (wrapper-instance-slots-layout owrapper))
1091          (setf (wrapper-class-slots nwrapper)
1092                (wrapper-class-slots owrapper))
1093          (without-interrupts
1094            #+cmu17
1095            (update-lisp-class-layout class nwrapper)
1096            (setf (slot-value class 'wrapper) nwrapper)
1097            (invalidate-wrapper owrapper ':obsolete nwrapper)
1098            class)))
1099    
1100    (defmethod make-instances-obsolete ((class symbol))
1101      (make-instances-obsolete (find-class class)))
1102    
1103    
1104    ;;;
1105    ;;; obsolete-instance-trap is the internal trap that is called when we see
1106    ;;; an obsolete instance.  The times when it is called are:
1107    ;;;   - when the instance is involved in method lookup
1108    ;;;   - when attempting to access a slot of an instance
1109    ;;;
1110    ;;; It is not called by class-of, wrapper-of, or any of the low-level instance
1111    ;;; access macros.
1112    ;;;
1113    ;;; Of course these times when it is called are an internal implementation
1114    ;;; detail of PCL and are not part of the documented description of when the
1115    ;;; obsolete instance update happens.  The documented description is as it
1116    ;;; appears in 88-002R.
1117    ;;;
1118    ;;; This has to return the new wrapper, so it counts on all the methods on
1119    ;;; obsolete-instance-trap-internal to return the new wrapper.  It also does
1120    ;;; a little internal error checking to make sure that the traps are only
1121    ;;; happening when they should, and that the trap methods are computing
1122    ;;; apropriate new wrappers.
1123    ;;;
1124    
1125    ;;; obsolete-instance-trap might be called on structure instances
1126    ;;; after a structure is redefined.  In most cases, obsolete-instance-trap
1127    ;;; will not be able to fix the old instance, so it must signal an
1128    ;;; error.  The hard part of this is that the error system and debugger
1129    ;;; might cause obsolete-instance-trap to be called again, so in that
1130    ;;; case, we have to return some reasonable wrapper, instead.
1131    
1132    (defvar *in-obsolete-instance-trap* nil)
1133    (defvar *the-wrapper-of-structure-object*
1134      (class-wrapper (find-class 'structure-object)))
1135    
1136    #+cmu17
1137    (define-condition obsolete-structure (error)
1138      ((datum :reader obsolete-structure-datum :initarg :datum))
1139      (:report
1140       (lambda (condition stream)
1141         ;; Don't try to print the structure, since it probably
1142         ;; won't work.
1143         (format stream "Obsolete structure error in ~S:~@
1144                         For a structure of type: ~S"
1145                 (conditions::condition-function-name condition)
1146                 (type-of (obsolete-structure-datum condition))))))
1147    
1148    (defun obsolete-instance-trap (owrapper nwrapper instance)
1149      (if (not #-(or cmu17 new-kcl-wrapper)
1150               (or (std-instance-p instance) (fsc-instance-p instance))
1151               #+cmu17
1152               (pcl-instance-p instance)
1153               #+new-kcl-wrapper
1154               nil)
1155          (if *in-obsolete-instance-trap*
1156              *the-wrapper-of-structure-object*
1157               (let ((*in-obsolete-instance-trap* t))
1158                 #-cmu17
1159                 (error "The structure ~S is obsolete." instance)
1160                 #+cmu17
1161                 (error 'obsolete-structure :datum instance)))
1162          (let* ((class (wrapper-class* nwrapper))
1163                 (copy (allocate-instance class)) ;??? allocate-instance ???
1164                 (olayout (wrapper-instance-slots-layout owrapper))
1165                 (nlayout (wrapper-instance-slots-layout nwrapper))
1166                 (oslots (get-slots instance))
1167                 (nslots (get-slots copy))
1168                 (oclass-slots (wrapper-class-slots owrapper))
1169                 (added ())
1170                 (discarded ())
1171                 (plist ()))
1172            ;; local  --> local        transfer
1173            ;; local  --> shared       discard
1174            ;; local  -->  --          discard
1175            ;; shared --> local        transfer
1176            ;; shared --> shared       discard
1177            ;; shared -->  --          discard
1178            ;;  --    --> local        add
1179            ;;  --    --> shared        --
1180            ;;
1181            ;; Go through all the old local slots.
1182            ;;
1183            (iterate ((name (list-elements olayout))
1184                      (opos (interval :from 0)))
1185              (let* ((opos opos)
1186                     (npos (posq name nlayout)))
1187                (declare (fixnum opos))
1188                (if npos
1189                    (setf (instance-ref nslots npos) (instance-ref oslots opos))
1190                    (progn
1191                      (push name discarded)
1192                      (unless (eq (instance-ref oslots opos) *slot-unbound*)
1193                        (setf (getf plist name) (instance-ref oslots opos)))))))
1194            ;;
1195            ;; Go through all the old shared slots.
1196            ;;
1197            (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
1198              (let ((name (car oclass-slot-and-val))
1199                    (val (cdr oclass-slot-and-val)))
1200                (let ((npos (posq name nlayout)))
1201                  (if npos
1202                      (setf (instance-ref nslots npos) (cdr oclass-slot-and-val))
1203                      (progn (push name discarded)
1204                             (unless (eq val *slot-unbound*)
1205                               (setf (getf plist name) val)))))))
1206            ;;
1207            ;; Go through all the new local slots to compute the added slots.
1208            ;;
1209            (dolist (nlocal nlayout)
1210              (unless (or (memq nlocal olayout)
1211                          (assq nlocal oclass-slots))
1212                (push nlocal added)))
1213          
1214            (swap-wrappers-and-slots instance copy)
1215    
1216            (update-instance-for-redefined-class instance
1217                                                 added
1218                                                 discarded
1219                                                 plist)
1220            nwrapper)))
1221    
1222    
1223    ;;;
1224    ;;;
1225    ;;;
1226    (defmacro copy-instance-internal (instance)
1227      `(#+new-kcl-wrapper if #-new-kcl-wrapper progn
1228                             #+new-kcl-wrapper (not (std-instance-p ,instance))
1229          (let* ((class (class-of instance))
1230                 (copy (allocate-instance class)))
1231             (if (std-instance-p ,instance)
1232                 (setf (std-instance-slots ,instance) (std-instance-slots ,instance))
1233                 (setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance)))
1234             copy)
1235          #+new-kcl-wrapper
1236          (copy-structure-header ,instance)))
1237    
1238    (defun change-class-internal (instance new-class initargs)
1239      (let* ((old-class (class-of instance))
1240             (copy (allocate-instance new-class))
1241             (new-wrapper (get-wrapper copy))
1242             (old-wrapper (class-wrapper old-class))
1243             (old-layout (wrapper-instance-slots-layout old-wrapper))
1244             (new-layout (wrapper-instance-slots-layout new-wrapper))
1245             (old-slots (get-slots instance))
1246             (new-slots (get-slots copy))
1247             (old-class-slots (wrapper-class-slots old-wrapper)))
1248    
1249        ;;
1250        ;; "The values of local slots specified by both the class Cto and
1251        ;; Cfrom are retained.  If such a local slot was unbound, it remains
1252        ;; unbound."
1253        ;;    
1254        (loop for new-slot in new-layout and new-position from 0
1255              for old-position = (posq new-slot old-layout)
1256              when old-position do
1257                (setf (instance-ref new-slots new-position)
1258                      (instance-ref old-slots old-position)))
1259    
1260        ;;
1261        ;; "The values of slots specified as shared in the class Cfrom and
1262        ;; as local in the class Cto are retained."
1263        ;;
1264        (loop for (name . val) in old-class-slots
1265              for new-position = (posq name new-layout)
1266              when new-position do
1267                (setf (instance-ref new-slots new-position) val))
1268    
1269        ;; Make the copy point to the old instance's storage, and make the
1270        ;; old instance point to the new storage.
1271        (swap-wrappers-and-slots instance copy)
1272    
1273        (apply #'update-instance-for-different-class copy instance initargs)
1274        instance))
1275    
1276    (defmethod change-class ((instance standard-object)
1277                             (new-class standard-class)
1278                             &rest initargs)
1279      (change-class-internal instance new-class initargs))
1280    
1281    ;; FIXME add class funcallable-standard-object ??
1282    ;(defmethod change-class ((instance funcallable-standard-object)
1283    ;                        (new-class funcallable-standard-class)
1284    ;                        &rest initargs)
1285    ;  (change-class-internal instance new-class initargs))
1286    
1287    (defmethod change-class ((instance standard-object)
1288                             (new-class funcallable-standard-class)
1289                             &rest initargs)
1290      (declare (ignore initargs))
1291      (error "Can't change the class of ~S to ~S~@
1292              because it isn't already an instance with metaclass ~S."
1293             instance new-class 'standard-class))
1294    
1295    ;(defmethod change-class ((instance funcallable-standard-object)
1296    ;                        (new-class standard-class)
1297    ;                        &rest initargs)
1298    ;  (declare (ignore initargs))
1299    ;  (error "Can't change the class of ~S to ~S~@
1300    ;          because it isn't already an instance with metaclass ~S."
1301    ;        instance new-class 'funcallable-standard-class))
1302    
1303    (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
1304      (apply #'change-class instance (find-class new-class-name) initargs))
1305    
1306    
1307    
1308    
1309    ;;;
1310    ;;; The metaclass BUILT-IN-CLASS
1311    ;;;
1312    ;;; This metaclass is something of a weird creature.  By this point, all
1313    ;;; instances of it which will exist have been created, and no instance
1314    ;;; is ever created by calling MAKE-INSTANCE.
1315    ;;;
1316    ;;; But, there are other parts of the protcol we must follow and those
1317    ;;; definitions appear here.
1318    ;;;
1319    (defmethod shared-initialize :before
1320               ((class built-in-class) slot-names &rest initargs)
1321      (declare (ignore slot-names initargs))
1322      (error "Attempt to initialize or reinitialize a built in class."))
1323    
1324    (defmethod class-direct-slots            ((class built-in-class)) ())
1325    (defmethod class-slots                   ((class built-in-class)) ())
1326    (defmethod class-direct-default-initargs ((class built-in-class)) ())
1327    (defmethod class-default-initargs        ((class built-in-class)) ())
1328    
1329    (defmethod validate-superclass ((c class) (s built-in-class))
1330      (eq s *the-class-t*))
1331    
1332    
1333    
1334    ;;;
1335    ;;;
1336    ;;;
1337    
1338    (defmethod validate-superclass ((c slot-class)
1339                                                    (f forward-referenced-class))
1340      't)
1341    
1342    
1343    ;;;
1344    ;;;
1345    ;;;
1346    
1347    (defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
1348      (pushnew dependent (plist-value metaobject 'dependents)))
1349    
1350    (defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
1351      (setf (plist-value metaobject 'dependents)
1352            (delete dependent (plist-value metaobject 'dependents))))
1353    
1354    (defmethod map-dependents ((metaobject dependent-update-mixin) function)
1355      (dolist (dependent (plist-value metaobject 'dependents))
1356        (funcall function dependent)))
1357    

Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26