/[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.43 by gerd, Thu Feb 6 15:20:12 2003 UTC revision 1.43.2.5 by gerd, Sat Mar 22 12:25:57 2003 UTC
# Line 27  Line 27 
27    
28  (ext:file-comment  (ext:file-comment
29    "$Header$")    "$Header$")
 ;;;  
30    
31  (in-package :pcl)  (in-package :pcl)
32    
# Line 90  Line 89 
89          (compute-slot-accessor-info slotd type gf)))          (compute-slot-accessor-info slotd type gf)))
90      (initialize-internal-slot-gfs name)))      (initialize-internal-slot-gfs name)))
91    
92  (defmethod compute-slot-accessor-info ((slotd effective-slot-definition) type gf)  (defmethod compute-slot-accessor-info ((slotd effective-slot-definition)
93                                           type gf)
94    (let* ((name (slot-value slotd 'name))    (let* ((name (slot-value slotd 'name))
95           (class (slot-value slotd 'class))           (class (slot-value slotd 'class))
96           (old-slotd (find-slot-definition class name))           (old-slotd (find-slot-definition class name))
# Line 101  Line 101 
101              (get-optimized-std-accessor-method-function class slotd type))              (get-optimized-std-accessor-method-function class slotd type))
102        (setf (slot-accessor-std-p slotd type) std-p)        (setf (slot-accessor-std-p slotd type) std-p)
103        (setf (slot-accessor-function slotd type) function))        (setf (slot-accessor-function slotd type) function))
104      (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))      ;;
105        (push (cons class name) *pv-table-cache-update-info*))))      ;; Optimized accessor functions use pv tables.
106        (when (and old-slotd
107                   (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
108          (record-pv-update-info slotd))))
109    
110  (defmethod slot-definition-allocation ((slotd structure-slot-definition))  (defmethod slot-definition-allocation ((slotd structure-slot-definition))
111    :instance)    :instance)
# Line 122  Line 125 
125    
126  (defmethod (setf documentation) (new-value object doc-type)  (defmethod (setf documentation) (new-value object doc-type)
127    (declare (ignore new-value doc-type))    (declare (ignore new-value doc-type))
128    (error "Can't change the documentation of ~S." object))    (error "~@<Can't change the documentation of ~S.~@:>" object))
129    
130  (defmethod documentation ((object documentation-mixin) doc-type)  (defmethod documentation ((object documentation-mixin) doc-type)
131    (declare (ignore doc-type))    (declare (ignore doc-type))
# Line 190  Line 193 
193  ;;; here, the values are read by an automatically generated reader method.  ;;; here, the values are read by an automatically generated reader method.
194  ;;;  ;;;
195  (defmethod add-direct-subclass ((class class) (subclass class))  (defmethod add-direct-subclass ((class class) (subclass class))
196      (check-seals class 'add-direct-subclass)
197    (with-slots (direct-subclasses) class    (with-slots (direct-subclasses) class
198      (pushnew subclass direct-subclasses)      (pushnew subclass direct-subclasses)
199      subclass))      subclass))
200    
201  (defmethod remove-direct-subclass ((class class) (subclass class))  (defmethod remove-direct-subclass ((class class) (subclass class))
202      (check-seals class 'remove-direct-subclass)
203    (with-slots (direct-subclasses) class    (with-slots (direct-subclasses) class
204      (setq direct-subclasses (remove subclass direct-subclasses))      (setq direct-subclasses (remove subclass direct-subclasses))
205      subclass))      subclass))
# Line 227  Line 232 
232    (with-slots (direct-methods) specializer    (with-slots (direct-methods) specializer
233      (setf (car direct-methods) (remove method (car direct-methods))      (setf (car direct-methods) (remove method (car direct-methods))
234            (cdr direct-methods) ()))            (cdr direct-methods) ()))
235      (remove-inline-access-method specializer method)
236    method)    method)
237    
238  (defmethod specializer-direct-methods ((specializer class))  (defmethod specializer-direct-methods ((specializer class))
# Line 248  Line 254 
254  ;;; 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
255  ;;; functions of EQL specializers.  Each value in the table is the cons.  ;;; functions of EQL specializers.  Each value in the table is the cons.
256  ;;;  ;;;
257  (defvar *eql-specializer-methods* (make-hash-table :test #'eql))  (defvar *eql-specializer-methods* (make-hash-table :test 'eql))
258  (defvar *class-eq-specializer-methods* (make-hash-table :test #'eq))  (defvar *class-eq-specializer-methods* (make-hash-table :test 'eq))
259    
260  (defmethod specializer-method-table ((specializer eql-specializer))  (defmethod specializer-method-table ((specializer eql-specializer))
261    *eql-specializer-methods*)    *eql-specializer-methods*)
# Line 307  Line 313 
313             *eql-specializer-table*)             *eql-specializer-table*)
314    nil)    nil)
315    
316    (defun map-all-classes (function &optional (root t))
317      (let ((braid-p (memq *boot-state* '(braid complete)))
318            (root (if (symbolp root) (find-class root) root)))
319        (labels ((map-class (class)
320                   (mapc #'map-class
321                         (if braid-p
322                             (class-direct-subclasses class)
323                             (early-class-direct-subclasses class)))
324                   (funcall function class)))
325          (map-class root))))
326    
327  (defun map-all-generic-functions (function)  (defun map-all-generic-functions (function)
328    (let ((all-generic-functions (make-hash-table :test 'eq)))    (let ((all-generic-functions (make-hash-table :test 'eq)))
329      (map-specializers (lambda (specl)      (map-specializers (lambda (specl)
# Line 327  Line 344 
344    
345    
346  (defun real-load-defclass (name metaclass-name supers slots other)  (defun real-load-defclass (name metaclass-name supers slots other)
347    (let ((res (apply #'ensure-class name :metaclass metaclass-name    (apply #'ensure-class name :metaclass metaclass-name
348                      :direct-superclasses supers           :direct-superclasses supers
349                      :direct-slots slots           :direct-slots slots
350                      :definition-source `((defclass ,name)           :definition-source `((defclass ,name) ,*load-pathname*)
351                                           ,*load-pathname*)           other))
                     other)))  
     ;; Defclass of a class with a forward-referenced superclass does not  
     ;; have a wrapper. RES is the incomplete PCL class. The Lisp class  
     ;; does not yet exist. Maybe should return NIL in that case as RES  
     ;; is not useful to the user?  
     (and (class-wrapper res)(kernel:layout-class (class-wrapper res)))))  
352    
353  (setf (gdefinition 'load-defclass) #'real-load-defclass)  (setf (gdefinition 'load-defclass) #'real-load-defclass)
354    
# Line 347  Line 358 
358  (defmethod ensure-class-using-class (name (class null) &rest args &key)  (defmethod ensure-class-using-class (name (class null) &rest args &key)
359    (multiple-value-bind (meta initargs)    (multiple-value-bind (meta initargs)
360        (ensure-class-values class args)        (ensure-class-values class args)
361      (inform-type-system-about-class (class-prototype meta) name);***      (inform-type-system-about-class (class-prototype meta) name)
362      (setf class (apply #'make-instance meta :name name initargs)      (setf class (apply #'make-instance meta :name name initargs)
363            (find-class name) class)            (find-class name) class)
364      (inform-type-system-about-class class name)                 ;***      (inform-type-system-about-class class name)
365      class))      class))
366    
367  (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)  (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
368    (multiple-value-bind (meta initargs)    (multiple-value-bind (meta initargs)
369        (ensure-class-values class args)        (ensure-class-values class args)
370      (unless (eq (class-of class) meta) (change-class class meta))      (unless (eq (class-of class) meta)
371          (change-class class meta))
372      (apply #'reinitialize-instance class initargs)      (apply #'reinitialize-instance class initargs)
373      (setf (find-class name) class)      (setf (find-class name) class)
374      (inform-type-system-about-class class name)                 ;***      (inform-type-system-about-class class name)
375      class))      class))
376    
377  (defmethod class-predicate-name ((class t))  (defmethod class-predicate-name ((class t))
# Line 370  Line 382 
382           (unsupplied (list 1))           (unsupplied (list 1))
383           (supplied-meta   (getf initargs :metaclass unsupplied))           (supplied-meta   (getf initargs :metaclass unsupplied))
384           (supplied-supers (getf initargs :direct-superclasses unsupplied))           (supplied-supers (getf initargs :direct-superclasses unsupplied))
385           (meta           (meta (cond ((neq supplied-meta unsupplied)
386             (cond ((neq supplied-meta unsupplied)                        (find-class supplied-meta))
387                    (find-class supplied-meta))                       ((or (null class)
388                   ((or (null class)                            (forward-referenced-class-p class))
389                        (forward-referenced-class-p class))                        *the-class-standard-class*)
390                    *the-class-standard-class*)                       (t
391                   (t                        (class-of class)))))
                   (class-of class)))))  
392      (flet ((fix-super (s)      (flet ((fix-super (s)
393               (cond ((classp s) s)               (cond ((classp s) s)
394                     ((not (legal-class-name-p s))                     ((not (legal-class-name-p s))
395                      (simple-program-error                      (simple-program-error
396                       "~S is not a class or a legal class name." s))                       "~@<~S is not a class or a legal class name.~@:>" s))
397                     (t                     (t
398                      (or (find-class s nil)                      (or (find-class s nil)
399                          (setf (find-class s)                          (setf (find-class s)
# Line 397  Line 408 
408              for slot-name = (getf slot :name)              for slot-name = (getf slot :name)
409              if (some (lambda (s) (eq slot-name (getf s :name))) more) do              if (some (lambda (s) (eq slot-name (getf s :name))) more) do
410                (simple-program-error                (simple-program-error
411                 "More than one direct slot with name ~S."                 "~@<More than one direct slot with name ~S.~@:>"
412                 slot-name)                 slot-name)
413              else do              else do
414                (loop for (option value . more) on slot by #'cddr                (loop for (option value . more) on slot by #'cddr
415                      when (and (member option '(:allocation :type :initform                      if (and (member option '(:allocation :type :initform
416                                                 :documentation))                                               :documentation))
417                                (not (eq unsupplied                              (not (eq unsupplied
418                                         (getf more option unsupplied)))) do                                       (getf more option unsupplied)))) do
419                          (simple-program-error
420                           "~@<Duplicate slot option ~S for slot ~S.~@:>"
421                           option slot-name)
422                        else if (and (eq option :readers)
423                                     (notevery #'symbolp value)) do
424                          (simple-program-error
425                           "~@<Slot ~S: slot reader names must be symbols.~@:>"
426                           slot-name)
427                        else if (and (eq option :initargs)
428                                     (notevery #'symbolp value)) do
429                        (simple-program-error                        (simple-program-error
430                         "Duplicate slot option ~S for slot ~S."                         "~@<Slot ~S: initarg names must be symbols.~@:>"
431                         option slot-name)))                         slot-name)))
432        ;;        ;;
433        ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name        ;; CLHS: signal PROGRAM-ERROR, if an initialization argument name
434        ;; appears more than once in :DEFAULT-INITARGS class option.        ;; appears more than once in :DEFAULT-INITARGS class option.
# Line 415  Line 436 
436              for name = (car initarg)              for name = (car initarg)
437              when (some (lambda (a) (eq (car a) name)) more) do              when (some (lambda (a) (eq (car a) name)) more) do
438                (simple-program-error                (simple-program-error
439                 "Duplicate initialization argument ~                 "~@<Duplicate initialization argument ~
440                  name ~S in :default-initargs of class ~A."                  name ~S in ~s of class ~A.~@:>"
441                 name class))                 name :default-initargs class))
442          ;;
443          (loop for (arg value) on initargs by #'cddr
444                count (eq arg :metaclass) into metaclass
445                count (eq arg :direct-default-initargs) into default-initargs
446                when (or (> metaclass 1) (> default-initargs 1)) do
447                  (simple-program-error
448                   "~@<Class ~S: More than one ~S specified~@:>"
449                   class (if (eq arg :direct-default-initargs)
450                             :default-initargs arg)))
451          (remf initargs :metaclass)
452          (remf initargs :direct-superclasses)
453        ;;        ;;
       (loop (unless (remf initargs :metaclass) (return)))  
       (loop (unless (remf initargs :direct-superclasses) (return)))  
454        (values meta        (values meta
455                (nconc                (nconc (when (neq supplied-supers unsupplied)
456                 (when (neq supplied-supers unsupplied)                         (list :direct-superclasses
457                   (list                               (mapcar #'fix-super supplied-supers)))
458                    :direct-superclasses                       initargs)))))
                   (mapcar #'fix-super supplied-supers)))  
                initargs)))))  
459    
460    
461  ;;;  ;;;
462  ;;;  ;;;
463  ;;;  ;;;
 #|| ; since it doesn't do anything  
 (defmethod shared-initialize :before ((class std-class)  
                                       slot-names  
                                       &key direct-superclasses)  
   (declare (ignore slot-names))  
   ;; *** error checking  
   )  
 ||#  
   
464  (defmethod shared-initialize :after  (defmethod shared-initialize :after
465             ((class std-class)             ((class std-class)
466              slot-names              slot-names
# Line 459  Line 478 
478                               *the-class-standard-object*))))                               *the-class-standard-object*))))
479           (dolist (superclass direct-superclasses)           (dolist (superclass direct-superclasses)
480             (unless (validate-superclass class superclass)             (unless (validate-superclass class superclass)
481               (error "The class ~S was specified as a~%               (error "~@<The class ~S was specified as a ~
482                       super-class of the class ~S;~%~                       super-class of the class ~S, ~
483                       but the meta-classes ~S and~%~S are incompatible.~@                       but the meta-classes ~S and ~S are incompatible.  ~
484                       Define a method for ~S to avoid this error."                       Define a method for ~S to avoid this error.~@:>"
485                       superclass class (class-of superclass) (class-of class)                       superclass class (class-of superclass) (class-of class)
486                       'validate-superclass)))                       'validate-superclass)))
487           (setf (slot-value class 'direct-superclasses) direct-superclasses))           (setf (slot-value class 'direct-superclasses) direct-superclasses))
# Line 539  Line 558 
558                      (mapcar (lambda (pl)                      (mapcar (lambda (pl)
559                                (when defstruct-p                                (when defstruct-p
560                                  (let* ((slot-name (getf pl :name))                                  (let* ((slot-name (getf pl :name))
561                                         (acc-name (format nil "~s structure class ~a"                                         (accessor
562                                                           name slot-name))                                          (symbolicate
563                                         (accessor (intern acc-name)))                                           *package*
564                                             (if (symbol-package name)
565                                                 (package-name (symbol-package name))
566                                                 "")
567                                             "::" name " structure class " slot-name)))
568                                    (setq pl (list* :defstruct-accessor-symbol accessor                                    (setq pl (list* :defstruct-accessor-symbol accessor
569                                                    pl))))                                                    pl))))
570                                (make-direct-slotd class pl))                                (make-direct-slotd class pl))
# Line 549  Line 572 
572          (setq direct-slots (slot-value class 'direct-slots)))          (setq direct-slots (slot-value class 'direct-slots)))
573      (when defstruct-p      (when defstruct-p
574        (let* ((include (car (slot-value class 'direct-superclasses)))        (let* ((include (car (slot-value class 'direct-superclasses)))
575               (conc-name (intern (format nil "~s structure class " name)))               (conc-name (symbolicate *package*
576               (constructor (intern (format nil "~a constructor" conc-name)))                                       (if (symbol-package name)
577                                             (package-name (symbol-package name))
578                                             "")
579                                         "::" name " structure class "))
580                 ;;
581                 ;; It's not possible to use a generalized name for the
582                 ;; constructor function.  It shouldn't matter though, I think,
583                 ;; like for the slot names above, because this stuff is not
584                 ;; supposed to be used by users directly.
585                 (constructor
586                   (symbolicate *package* conc-name " constructor"))
587               (defstruct `(defstruct (,name               (defstruct `(defstruct (,name
588                                        ,@(when include                                        ,@(when include
589                                            `((:include ,(class-name include))))                                            `((:include ,(class-name include))))
590                                        (:predicate nil)                                        (:predicate nil)
591                                        (:conc-name ,conc-name)                                        (:conc-name ,conc-name)
592                                        (:constructor ,constructor ()))                                        (:constructor ,constructor ()))
593                               ;;
594                               ;; Use a temporary unbound marker that lets
595                               ;; SHARED-INITIALIZE recognize if a before-method
596                               ;; has written to a slot.
597                             ,@(mapcar (lambda (slot)                             ,@(mapcar (lambda (slot)
598                                         `(,(slot-definition-name slot)                                         `(,(slot-definition-name slot)
599                                           +slot-unbound+))                                           '.unbound.))
600                                       direct-slots)))                                       direct-slots)))
601               (reader-names (mapcar (lambda (slotd)               (reader-names (mapcar (lambda (slotd)
602                                       (intern (format nil "~A~A reader" conc-name                                       (list 'slot-accessor name
603                                                       (slot-definition-name slotd))))                                             (slot-definition-name slotd)
604                                               'reader))
605                                     direct-slots))                                     direct-slots))
606               (writer-names (mapcar (lambda (slotd)               (writer-names (mapcar (lambda (slotd)
607                                       (intern (format nil "~A~A writer" conc-name                                       (list 'slot-accessor name
608                                                       (slot-definition-name slotd))))                                             (slot-definition-name slotd)
609                                               'writer))
610                                     direct-slots))                                     direct-slots))
611               (readers-init               (readers-init
612                (mapcar (lambda (slotd reader-name)                (mapcar (lambda (slotd reader-name)
# Line 603  Line 642 
642    (setf (slot-value class 'class-precedence-list)    (setf (slot-value class 'class-precedence-list)
643          (compute-class-precedence-list class))          (compute-class-precedence-list class))
644    (setf (slot-value class 'slots) (compute-slots class))    (setf (slot-value class 'slots) (compute-slots class))
645    (let ((lclass (lisp:find-class (class-name class))))    (let ((lclass (kernel::find-class (class-name class))))
646      (setf (kernel:class-pcl-class lclass) class)      (setf (kernel:%class-pcl-class lclass) class)
647      (setf (slot-value class 'wrapper) (kernel:class-layout lclass)))      (setf (slot-value class 'wrapper) (kernel:%class-layout lclass)))
648    (update-pv-table-cache-info class)    (update-pv-table-cache-info class)
649    (setq predicate-name (if predicate-name-p    (setq predicate-name (if predicate-name-p
650                             (setf (slot-value class 'predicate-name)                             (setf (slot-value class 'predicate-name)
# Line 629  Line 668 
668  (defun remove-slot-accessors (class dslotds)  (defun remove-slot-accessors (class dslotds)
669    (fix-slot-accessors class dslotds 'remove))    (fix-slot-accessors class dslotds 'remove))
670    
671  (defun fix-slot-accessors (class dslotds add/remove)  (defun fix-slot-accessors (class dslotds add/remove)
672    (flet ((fix (gfspec name r/w)    (flet ((fix (gfspec name r/w)
673             (let ((gf (ensure-generic-function gfspec)))             (let ((gf (ensure-generic-function gfspec)))
674               (case r/w               (case r/w
# Line 641  Line 680 
680                        (remove-writer-method class gf)))))))                        (remove-writer-method class gf)))))))
681      (dolist (dslotd dslotds)      (dolist (dslotd dslotds)
682        (let ((slot-name (slot-definition-name dslotd)))        (let ((slot-name (slot-definition-name dslotd)))
683          (dolist (r (slot-definition-readers dslotd)) (fix r slot-name 'r))          (dolist (r (slot-definition-readers dslotd))
684          (dolist (w (slot-definition-writers dslotd)) (fix w slot-name 'w))))))            (fix r slot-name 'r))
685            (dolist (w (slot-definition-writers dslotd))
686              (fix w slot-name 'w))))))
687    
688    
689  (defun add-direct-subclasses (class new)  (defun add-direct-subclasses (class new)
# Line 664  Line 705 
705    
706  (defmethod finalize-inheritance ((class forward-referenced-class))  (defmethod finalize-inheritance ((class forward-referenced-class))
707    (simple-program-error    (simple-program-error
708     "Forward-referenced classes cannot be finalized: ~A"     "~@<Forward-referenced classes cannot be finalized: ~A.~@:>"
709     class))     class))
710    
711    
# Line 677  Line 718 
718  ;;; Called by :after shared-initialize whenever a class is initialized or  ;;; Called by :after shared-initialize whenever a class is initialized or
719  ;;; reinitialized.  The class may or may not be finalized.  ;;; reinitialized.  The class may or may not be finalized.
720  ;;;  ;;;
721  (defun update-class (class finalizep)  (defun update-class (class finalizep)
   ;; Comment from Gerd Moellmann:  
722    ;;    ;;
723    ;; Note that we can't simply delay the finalization when CLASS has    ;; Calling UPDATE-SLOTS below sets the class wrapper of CLASS, which
724    ;; no forward referenced superclasses because that causes bootstrap    ;; makes the class finalized.  When UPDATE-CLASS isn't called from
725    ;; problems.    ;; FINALIZE-INHERITANCE, make sure that this finalization invokes
726    (when (and (not finalizep)    ;; FINALIZE-INHERITANCE as per AMOP.  Note that we can't simply
727               (not (class-finalized-p class))    ;; delay the finalization when CLASS has no forward referenced
728      ;; superclasses because that causes bootstrap problems.
729      (when (and (not (or finalizep (class-finalized-p class)))
730               (not (class-has-a-forward-referenced-superclass-p class)))               (not (class-has-a-forward-referenced-superclass-p class)))
731      (finalize-inheritance class)      (finalize-inheritance class)
732      (return-from update-class))      (return-from update-class))
733    (when (or finalizep (class-finalized-p class)    ;;
734      (when (or finalizep
735                (class-finalized-p class)
736              (not (class-has-a-forward-referenced-superclass-p class)))              (not (class-has-a-forward-referenced-superclass-p class)))
737      (update-cpl class (compute-class-precedence-list class))      (update-cpl class (compute-class-precedence-list class))
     ;; This invocation of UPDATE-SLOTS, in practice, finalizes the  
     ;; class.  The hoops above are to ensure that FINALIZE-INHERITANCE  
     ;; is called at finalization, so that MOP programmers can hook  
     ;; into the system as described in "Class Finalization Protocol"  
     ;; (section 5.5.2 of AMOP).  
738      (update-slots class (compute-slots class))      (update-slots class (compute-slots class))
739      (update-gfs-of-class class)      (update-gfs-of-class class)
740      (update-inits class (compute-default-initargs class))      (update-inits class (compute-default-initargs class))
741      (update-make-instance-function-table class))      (update-ctors 'finalize-inheritance :class class))
742      ;;
743    (unless finalizep    (unless finalizep
744      (dolist (sub (class-direct-subclasses class)) (update-class sub nil))))      (dolist (sub (class-direct-subclasses class))
745          (update-class sub nil))))
746    
747  (defun update-cpl (class cpl)  (defun update-cpl (class cpl)
748    (if (class-finalized-p class)    (if (class-finalized-p class)
# Line 747  Line 788 
788                    ;;                    ;;
789                    ;; We cannot reuse the old wrapper easily when it                    ;; We cannot reuse the old wrapper easily when it
790                    ;; has class slot cells, even if these cells are                    ;; has class slot cells, even if these cells are
791                    ;; equal to the ones used in the new wrapper.  The                    ;; EQUAL to the ones used in the new wrapper.  The
792                    ;; class slot cells of OWRAPPER may be referenced                    ;; class slot cells of OWRAPPER may be referenced
793                    ;; from caches, and if we don't change the wrapper,                    ;; from caches, and if we don't change the wrapper,
794                    ;; the caches won't notice that something has                    ;; the caches won't notice that something has
# Line 775  Line 816 
816                wrapper nwrapper))                wrapper nwrapper))
817    
818        (unless (eq owrapper nwrapper)        (unless (eq owrapper nwrapper)
819            (update-inline-access class)
820          (update-pv-table-cache-info class)))))          (update-pv-table-cache-info class)))))
821    
822  (defun compute-class-slots (eslotds)  (defun compute-class-slots (eslotds)
# Line 833  Line 875 
875    
876  (defun make-direct-slotd (class initargs)  (defun make-direct-slotd (class initargs)
877    (let ((initargs (list* :class class initargs)))    (let ((initargs (list* :class class initargs)))
878      (apply #'make-instance (direct-slot-definition-class class initargs) initargs)))      (apply #'make-instance (direct-slot-definition-class class initargs)
879               initargs)))
880    
881  ;;;  ;;;
882  ;;;  ;;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once
883    ;;; for each different slot name we find in our superclasses.  Each
884    ;;; call receives the class and a list of the dslotds with that name.
885    ;;; The list is in most-specific-first order.
886  ;;;  ;;;
887  (defmethod compute-slots ((class std-class))  (defmethod compute-slots ((class std-class))
888    ;;    (loop with names/slots = ()
889    ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once          for c in (class-precedence-list class) do
890    ;; for each different slot name we find in our superclasses.  Each            (loop for slot in (class-direct-slots c)
891    ;; call receives the class and a list of the dslotds with that name.                  as name = (slot-definition-name slot)
892    ;; The list is in most-specific-first order.                  as entry = (assq name names/slots) do
893    ;;                    (if entry
894    (let ((name-dslotds-alist ()))                        (push slot (cdr entry))
895      (dolist (c (class-precedence-list class))                        (push (list name slot) names/slots)))
896        (dolist (slot (class-direct-slots c))          finally
897          (let* ((name (slot-definition-name slot))            (return
898                 (entry (assq name name-dslotds-alist)))              (loop for (name . slots) in names/slots collect
899            (if entry                      (compute-effective-slot-definition
900                (push slot (cdr entry))                       class (nreverse slots))))))
901                (push (list name slot) name-dslotds-alist)))))  
902      (mapcar (lambda (direct)  ;;;
903                (compute-effective-slot-definition class  ;;; These are the specified AMOP methods.
904                                                   (nreverse (cdr direct))))  ;;;
             name-dslotds-alist)))  
905    
906  (defmethod compute-slots ((class standard-class))  (defmethod compute-slots ((class standard-class))
907    (call-next-method))    (call-next-method))
908    
909  (defmethod compute-slots :around ((class standard-class))  (defmethod compute-slots :around ((class standard-class))
910    (let ((eslotds (call-next-method))    (loop with slotds = (call-next-method) and location = -1
911          (location -1))          for slot in slotds do
912      (dolist (eslotd eslotds eslotds)            (setf (slot-definition-location slot)
913        (setf (slot-definition-location eslotd)                  (ecase (slot-definition-allocation slot)
914              (ecase (slot-definition-allocation eslotd)                    (:instance
915                (:instance                     (incf location))
916                 (incf location))                    (:class
917                (:class                     (let* ((name (slot-definition-name slot))
918                 (let* ((name (slot-definition-name eslotd))                            (from-class (slot-definition-allocation-class slot))
919                        (from-class (slot-definition-allocation-class eslotd))                            (cell (assq name (class-slot-cells from-class))))
920                        (cell (assq name (class-slot-cells from-class))))                       (assert (consp cell))
921                   (assert (consp cell))                       cell))))
922                   cell))))            (initialize-internal-slot-functions slot)
923        (initialize-internal-slot-functions eslotd))))          finally
924              (return slotds)))
925    
926  (defmethod compute-slots ((class funcallable-standard-class))  (defmethod compute-slots ((class funcallable-standard-class))
927    (call-next-method))    (call-next-method))
928    
929  (defmethod compute-slots :around ((class funcallable-standard-class))  (defmethod compute-slots :around ((class funcallable-standard-class))
930    (labels ((instance-slot-names (slotds)    (labels (;;
931               (let (collect)             ;; Return a list of the names of instance slots in SLOTDS.
932                 (dolist (slotd slotds (nreverse collect))             (instance-slot-names (slotds)
933                   (when (eq (slot-definition-allocation slotd) :instance)               (loop for e in slotds
934                     (push (slot-definition-name slotd) collect)))))                     when (eq (slot-definition-allocation e) :instance)
935                         collect (slot-definition-name e)))
936               ;;
937             ;; This sorts slots so that slots of classes later in the CPL             ;; This sorts slots so that slots of classes later in the CPL
938             ;; come before slots of other classes.  This is crucial for             ;; come before slots of other classes.  This is crucial for
939             ;; funcallable instances because it ensures that the slots of             ;; funcallable instances because it ensures that the slots of
940             ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of             ;; FUNCALLABLE-STANDARD-OBJECT, which includes the slots of
941             ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn             ;; KERNEL:FUNCALLABLE-INSTANCE, come first, which in turn
942             ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as             ;; makes it possible to treat FUNCALLABLE-STANDARD-OBJECT as
943             ;; a funcallable instance.             ;; a funcallable instance.
944             (compute-layout (eslotds)             (compute-layout (eslotds)
945               (let ((first ())               (loop with first = ()
946                     (names (instance-slot-names eslotds)))                     with names = (instance-slot-names eslotds)
947                 (dolist (class                     for class in (reverse (class-precedence-list class)) do
948                           (reverse (class-precedence-list class))                       (loop for ss in (class-slots class)
949                          (nreverse (nconc names first)))                             as name = (slot-definition-name ss)
950                   (dolist (ss (class-slots class))                             when (member name names) do
951                     (let ((name (slot-definition-name ss)))                               (push name first)
952                       (when (member name names)                               (setq names (delete name names)))
953                         (push name first)                     finally (return (nreverse (nconc names first))))))
954                         (setq names (delete name names)))))))))      ;;
955      (let ((all-slotds (call-next-method))      (let ((all-slotds (call-next-method))
956            (instance-slots ())            (instance-slots ())
957            (class-slots ()))            (class-slots ()))
958        (dolist (slotd all-slotds)        (loop for slotd in all-slotds do
959          (ecase (slot-definition-allocation slotd)                (ecase (slot-definition-allocation slotd)
960            (:instance (push slotd instance-slots))                  (:instance (push slotd instance-slots))
961            (:class (push slotd class-slots))))                  (:class    (push slotd class-slots))))
962        (let ((layout (compute-layout instance-slots)))        (loop with layout = (compute-layout instance-slots)
963          (dolist (slotd instance-slots)              for slotd in instance-slots do
964            (setf (slot-definition-location slotd)                (setf (slot-definition-location slotd)
965                  (position (slot-definition-name slotd) layout))                      (position (slot-definition-name slotd) layout))
966            (initialize-internal-slot-functions slotd)))                (initialize-internal-slot-functions slotd))
967        (dolist (slotd class-slots)        (loop for slotd in class-slots
968          (let ((name (slot-definition-name slotd))              as name = (slot-definition-name slotd)
969                (from-class (slot-definition-allocation-class slotd)))              as from-class = (slot-definition-allocation-class slotd) do
970            (setf (slot-definition-location slotd)                (setf (slot-definition-location slotd)
971                  (assoc name (class-slot-cells from-class)))                      (assoc name (class-slot-cells from-class)))
972            (assert (consp (slot-definition-location slotd)))                (assert (consp (slot-definition-location slotd)))
973            (initialize-internal-slot-functions slotd)))                (initialize-internal-slot-functions slotd))
974        all-slotds)))        all-slotds)))
975    
976  (defmethod compute-slots ((class structure-class))  (defmethod compute-slots ((class structure-class))
# Line 1044  Line 1092 
1092    
1093  (defmethod remove-reader-method ((class slot-class) generic-function)  (defmethod remove-reader-method ((class slot-class) generic-function)
1094    (let ((method (get-method generic-function () (list class) nil)))    (let ((method (get-method generic-function () (list class) nil)))
1095      (when method (remove-method generic-function method))))      (when method
1096          (remove-method generic-function method))))
1097    
1098  (defmethod remove-writer-method ((class slot-class) generic-function)  (defmethod remove-writer-method ((class slot-class) generic-function)
1099    (let ((method    (let ((method (get-method generic-function ()
1100            (get-method generic-function () (list *the-class-t* class) nil)))                              (list *the-class-t* class) nil)))
1101      (when method (remove-method generic-function method))))      (when method
1102          (remove-method generic-function method))))
1103    
1104  (defmethod remove-boundp-method ((class slot-class) generic-function)  (defmethod remove-boundp-method ((class slot-class) generic-function)
1105    (let ((method (get-method generic-function () (list class) nil)))    (let ((method (get-method generic-function () (list class) nil)))
1106      (when method (remove-method generic-function method))))      (when method
1107          (remove-method generic-function method))))
1108    
1109    
1110  ;;;  ;;;
# Line 1093  Line 1144 
1144  (defmethod inform-type-system-about-class ((class std-class) name)  (defmethod inform-type-system-about-class ((class std-class) name)
1145    ;; Maybe add skeleton lisp:standard-class to avoid undefined-function    ;; Maybe add skeleton lisp:standard-class to avoid undefined-function
1146    ;; compiler warnings. Not otherwise needed in this implementation.    ;; compiler warnings. Not otherwise needed in this implementation.
1147    (inform-type-system-about-std-class name))    (inform-type-system-about-std-class name)
1148      (set-class-translation class name))
1149    
1150    (defmethod inform-type-system-about-class ((class funcallable-standard-class)
1151                                               name)
1152      (set-class-translation class name))
1153    
1154  (defmethod inform-type-system-about-class  (defmethod inform-type-system-about-class ((class structure-class) name)
1155      ((class funcallable-standard-class) name)    (set-class-translation class name))
1156    (declare (ignore name))  
1157    ;; Avoid load-time warning of changing metaclass.  (defmethod inform-type-system-about-class ((class condition-class) name)
1158    )    (set-class-translation class name))
1159    
1160    
1161    
# Line 1139  Line 1195 
1195  ;;;  ;;;
1196  (defun force-cache-flushes (class)  (defun force-cache-flushes (class)
1197    (let* ((owrapper (class-wrapper class)))    (let* ((owrapper (class-wrapper class)))
     ;;  
     ;; We only need to do something if the wrapper is still valid.  If the  
     ;; wrapper isn't valid, state will be FLUSH or OBSOLETE, and both of those  
     ;; 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.  
     ;;  
1198      (when (or (not (invalid-wrapper-p owrapper))      (when (or (not (invalid-wrapper-p owrapper))
1199                (eq :invalid (kernel:layout-invalid owrapper)))                (eq :invalid (kernel:layout-invalid owrapper)))
1200        (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)        (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper)
# Line 1161  Line 1210 
1210    
1211  (defun flush-cache-trap (owrapper nwrapper instance)  (defun flush-cache-trap (owrapper nwrapper instance)
1212    (declare (ignore owrapper))    (declare (ignore owrapper))
1213    (set-wrapper instance nwrapper))    (cond ((std-instance-p instance)
1214             (setf (std-instance-wrapper instance) nwrapper))
1215            ((fsc-instance-p instance)
1216             (setf (fsc-instance-wrapper instance) nwrapper))
1217            (t
1218             (internal-error "Internal error."))))
1219    
1220    
   
1221  ;;;  ;;;
1222  ;;; 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
1223  ;;; 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
# Line 1217  Line 1270 
1270  ;;; case, we have to return some reasonable wrapper, instead.  ;;; case, we have to return some reasonable wrapper, instead.
1271    
1272  (defvar *in-obsolete-instance-trap* nil)  (defvar *in-obsolete-instance-trap* nil)
1273    
1274  (defvar *the-wrapper-of-structure-object*  (defvar *the-wrapper-of-structure-object*
1275    (class-wrapper (find-class 'structure-object)))    (class-wrapper (find-class 'structure-object)))
1276    
# Line 1226  Line 1280 
1280     (lambda (condition stream)     (lambda (condition stream)
1281       ;; Don't try to print the structure, since it probably       ;; Don't try to print the structure, since it probably
1282       ;; won't work.       ;; won't work.
1283       (format stream "Obsolete structure error in ~S:~@       (format stream "~@<Obsolete structure error in ~S ~
1284                       For a structure of type: ~S"                       for a structure of type ~S.~@:>"
1285               (conditions::condition-function-name condition)               (conditions::condition-function-name condition)
1286               (type-of (obsolete-structure-datum condition))))))               (type-of (obsolete-structure-datum condition))))))
1287    
# Line 1261  Line 1315 
1315          (loop for name in olayout and opos from 0          (loop for name in olayout and opos from 0
1316                as npos = (posq name nlayout)                as npos = (posq name nlayout)
1317                if npos do                if npos do
1318                  (setf (instance-ref nslots npos)                  (setf (slot-ref nslots npos)
1319                        (instance-ref oslots opos))                        (slot-ref oslots opos))
1320                else do                else do
1321                  (push name discarded)                  (push name discarded)
1322                  (unless (eq (instance-ref oslots opos) +slot-unbound+)                  (unless (eq (slot-ref oslots opos) +slot-unbound+)
1323                    (setf (getf plist name)                    (setf (getf plist name)
1324                          (instance-ref oslots opos))))                          (slot-ref oslots opos))))
1325          ;;          ;;
1326          ;; Go through all the old shared slots.          ;; Go through all the old shared slots.
1327          ;;          ;;
1328          (loop for (name . val) in oclass-slots          (loop for (name . val) in oclass-slots
1329                for npos = (posq name nlayout)                for npos = (posq name nlayout)
1330                if npos do                if npos do
1331                  (setf (instance-ref nslots npos) val)                  (setf (slot-ref nslots npos) val)
1332                else do                else do
1333                  (push name discarded)                  (push name discarded)
1334                  (unless (eq val +slot-unbound+)                  (unless (eq val +slot-unbound+)
# Line 1299  Line 1353 
1353  ;;;  ;;;
1354  ;;;  ;;;
1355  ;;;  ;;;
 (defmacro copy-instance-internal (instance)  
   `(progn  
       (let* ((class (class-of instance))  
              (copy (allocate-instance class)))  
          (if (std-instance-p ,instance)  
              (setf (std-instance-slots ,instance) (std-instance-slots ,instance))  
              (setf (fsc-instance-slots ,instance) (fsc-instance-slots ,instance)))  
          copy)))  
   
1356  (defun change-class-internal (instance new-class initargs)  (defun change-class-internal (instance new-class initargs)
1357    (let* ((old-class (class-of instance))    (let* ((old-class (class-of instance))
1358           (copy (allocate-instance new-class))           (copy (allocate-instance new-class))
# Line 1327  Line 1372 
1372      (loop for new-slot in new-layout and new-position from 0      (loop for new-slot in new-layout and new-position from 0
1373            for old-position = (posq new-slot old-layout)            for old-position = (posq new-slot old-layout)
1374            when old-position do            when old-position do
1375              (setf (instance-ref new-slots new-position)              (setf (slot-ref new-slots new-position)
1376                    (instance-ref old-slots old-position)))                    (slot-ref old-slots old-position)))
1377      ;;      ;;
1378      ;; "The values of slots specified as shared in the class Cfrom and      ;; "The values of slots specified as shared in the class Cfrom and
1379      ;; as local in the class Cto are retained."      ;; as local in the class Cto are retained."
# Line 1336  Line 1381 
1381      (loop for (name . val) in old-class-slots      (loop for (name . val) in old-class-slots
1382            for new-position = (posq name new-layout)            for new-position = (posq name new-layout)
1383            when new-position do            when new-position do
1384              (setf (instance-ref new-slots new-position) val))              (setf (slot-ref new-slots new-position) val))
1385    
1386      ;; 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
1387      ;; old instance point to the new storage.      ;; old instance point to the new storage.
# Line 1359  Line 1404 
1404                           (new-class funcallable-standard-class)                           (new-class funcallable-standard-class)
1405                           &rest initargs)                           &rest initargs)
1406    (declare (ignore initargs))    (declare (ignore initargs))
1407    (error "Can't change the class of ~S to ~S~@    (error "~@<Can't change the class of ~S to ~S ~
1408            because it isn't already an instance with metaclass ~S."            because it isn't already an instance with metaclass ~S.~@:>"
1409           instance new-class 'standard-class))           instance new-class 'standard-class))
1410    
1411  (defmethod change-class ((instance funcallable-standard-object)  (defmethod change-class ((instance funcallable-standard-object)
1412                           (new-class standard-class)                           (new-class standard-class)
1413                           &rest initargs)                           &rest initargs)
1414    (declare (ignore initargs))    (declare (ignore initargs))
1415    (error "Can't change the class of ~S to ~S~@    (error "~@<Can't change the class of ~S to ~S ~
1416            because it isn't already an instance with metaclass ~S."            because it isn't already an instance with metaclass ~S.~@:>"
1417           instance new-class 'funcallable-standard-class))           instance new-class 'funcallable-standard-class))
1418    
1419  (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)  (defmethod change-class ((instance t) (new-class-name symbol) &rest initargs)
# Line 1389  Line 1434 
1434  (defmethod shared-initialize :before  (defmethod shared-initialize :before
1435             ((class built-in-class) slot-names &rest initargs)             ((class built-in-class) slot-names &rest initargs)
1436    (declare (ignore slot-names initargs))    (declare (ignore slot-names initargs))
1437    (error "Attempt to initialize or reinitialize a built in class."))    (error "Attempt to initialize or reinitialize a built-in class."))
1438    
1439  (defmethod class-direct-slots            ((class built-in-class)) ())  (defmethod class-direct-slots            ((class built-in-class)) ())
1440  (defmethod class-slots                   ((class built-in-class)) ())  (defmethod class-slots                   ((class built-in-class)) ())
# Line 1397  Line 1442 
1442  (defmethod class-default-initargs        ((class built-in-class)) ())  (defmethod class-default-initargs        ((class built-in-class)) ())
1443    
1444  (defmethod validate-superclass ((c class) (s built-in-class))  (defmethod validate-superclass ((c class) (s built-in-class))
1445    (or (eq s *the-class-t*) (eq s *the-class-stream*)))    (or (eq s *the-class-t*)
1446          (eq s *the-class-stream*)))
1447    
1448    
1449    
# Line 1405  Line 1451 
1451  ;;;  ;;;
1452  ;;;  ;;;
1453    
1454    (macrolet ((frob (method)
1455               `(defmethod ,method ((class forward-referenced-class))
1456                  (declare (ignore class))
1457                  ())))
1458      (frob class-direct-slots)
1459      (frob class-direct-default-initargs))
1460    
1461    (macrolet ((frob (method)
1462                 `(defmethod ,method ((class forward-referenced-class))
1463                    (error "~@<~S called for forward referenced class ~S.~@:>"
1464                           ',method class))))
1465      (frob class-default-initargs)
1466      (frob class-precedence-list)
1467      (frob class-slots))
1468    
1469  (defmethod validate-superclass ((c slot-class)  (defmethod validate-superclass ((c slot-class)
1470                                  (f forward-referenced-class))                                  (f forward-referenced-class))
1471    t)    t)
# Line 1425  Line 1486 
1486    (dolist (dependent (plist-value metaobject 'dependents))    (dolist (dependent (plist-value metaobject 'dependents))
1487      (funcall function dependent)))      (funcall function dependent)))
1488    
1489    
1490    ;;;
1491    ;;; Conditions
1492    ;;;
1493    (defmethod shared-initialize :after ((class condition-class) slot-names
1494                                         &key direct-superclasses)
1495      (declare (ignore slot-names))
1496      (let ((kernel-class (kernel::find-class (class-name class))))
1497        (with-slots (wrapper class-precedence-list prototype predicate-name
1498                             (direct-supers direct-superclasses))
1499            class
1500          (setf (kernel:%class-pcl-class kernel-class) class)
1501          (setq direct-supers direct-superclasses)
1502          (setq wrapper (kernel:%class-layout kernel-class))
1503          (setq class-precedence-list (compute-class-precedence-list class))
1504          (setq prototype (make-condition (class-name class)))
1505          (add-direct-subclasses class direct-superclasses)
1506          (setq predicate-name (make-class-predicate-name (class-name class)))
1507          (make-class-predicate class predicate-name))))
1508    

Legend:
Removed from v.1.43  
changed lines
  Added in v.1.43.2.5

  ViewVC Help
Powered by ViewVC 1.1.5