;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-


;;; File converted on 10-Apr-91 22:24:19 from source std-class
;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>std-class.;4 created 20-Feb-91 13:07:14

;;;. Copyright (c) 1991 by Venue


(in-package "CLOS")



(define-gf-predicate classp class)

(define-gf-predicate standard-class-p standard-class)

(define-gf-predicate forward-referenced-class-p forward-referenced-class)

(defmethod shared-initialize :after ((object documentation-mixin)
                                     slot-names &key documentation)
       (declare (ignore slot-names))
       (setf (plist-value object 'documentation)
             documentation))

(defmethod documentation (object &optional doc-type)
       (cl:documentation object doc-type))

(defmethod (setf documentation)
       (new-value object &optional doc-type)
       (declare (ignore new-value doc-type))
       (error "Can't change the documentation of ~S." object))

(defmethod documentation ((object documentation-mixin)
                          &optional doc-type)
  (declare (ignore doc-type))
  (car (plist-value object 'documentation)))

(defmethod (setf documentation)
       (new-value (object documentation-mixin)
              &optional doc-type)
       (declare (ignore doc-type))
       (setf (plist-value object 'documentation)
             new-value))

(defmethod documentation ((slotd standard-slot-definition)
                          &optional doc-type)
       (declare (ignore doc-type))
       (slot-value slotd 'documentation))

(defmethod (setf documentation)
       (new-value (slotd standard-slot-definition)
              &optional doc-type)
       (declare (ignore doc-type))
       (setf (slot-value slotd 'documentation)
             new-value))

(defmethod documentation ((method standard-method) &optional doc-type)
  (declare (ignore doc-type))
  (plist-value method 'documentation))

(defmethod (setf documentation)
	   (new-value (method standard-method)
		      &optional doc-type)
  (declare (ignore doc-type))
  (setf (plist-value method 'documentation) new-value))

;;; Various class accessors that are a little more complicated than can be done with automatically
;;; generated reader methods. 


(defmethod class-wrapper ((class clos-class))
       (with-slots (wrapper)
           class
         (let ((w? wrapper))
              (if (consp w?)
                  (let ((new (make-wrapper class)))
                       (setf (wrapper-instance-slots-layout new)
                             (car w?)
                             (wrapper-class-slots new)
                             (cdr w?))
                       (setq wrapper new))
                  w?))))

(defmethod class-precedence-list ((class clos-class))
       (unless (class-finalized-p class)
              (finalize-inheritance class))
       (with-slots (class-precedence-list)
           class
         class-precedence-list))

(defmethod class-finalized-p ((class clos-class))
       (with-slots (wrapper)
           class
         (not (null wrapper))))

(defmethod class-prototype ((class std-class))
       (with-slots (prototype)
           class
         (or prototype (setq prototype (allocate-instance class)))))

(defmethod class-direct-default-initargs ((class std-class))
       (plist-value class 'direct-default-initargs))

(defmethod class-default-initargs ((class std-class))
       (plist-value class 'default-initargs))

(defmethod class-constructors ((class std-class))
       (plist-value class 'constructors))

(defmethod class-slot-cells ((class std-class))
       (plist-value class 'class-slot-cells))


;;; Class accessors that are even a little bit more complicated than those above.  These have a
;;; protocol for updating them, we must implement that protocol. Maintaining the direct subclasses
;;; backpointers.  The update methods are here, the values are read by an automatically generated
;;; reader method. 


(defmethod add-direct-subclass ((class class)
                                (subclass class))
       (with-slots (direct-subclasses)
           class
         (pushnew subclass direct-subclasses)
         subclass))

(defmethod remove-direct-subclass ((class class)
                                   (subclass class))
       (with-slots (direct-subclasses)
           class
         (setq direct-subclasses (remove subclass direct-subclasses))
         subclass))


;;; Maintaining the direct-methods and direct-generic-functions backpointers. There are four generic
;;; functions involved, each has one method for the class case and another method for the damned EQL
;;; specializers. All of these are specified methods and appear in their specified place in the
;;; class graph. ADD-METHOD-ON-SPECIALIZER REMOVE-METHOD-ON-SPECIALIZER SPECIALIZER-METHODS
;;; SPECIALIZER-GENERIC-FUNCTIONS In each case, we maintain one value which is a cons.  The car is
;;; the list methods.  The cdr is a list of the generic functions.  The cdr is always computed
;;; lazily. 


(defmethod add-method-on-specializer ((method method)
                                      (specializer class))
       (with-slots (direct-methods)
           specializer
         (setf (car direct-methods)
               (adjoin method (car direct-methods))
               (cdr direct-methods)
               nil))
       method)

(defmethod remove-method-on-specializer ((method method)
                                         (specializer class))
       (with-slots (direct-methods)
           specializer
         (setf (car direct-methods)
               (remove method (car direct-methods))
               (cdr direct-methods)
               nil))
       method)

(defmethod specializer-methods ((specializer class))
       (with-slots (direct-methods)
           specializer
         (car direct-methods)))

(defmethod specializer-generic-functions ((specializer class))
       (with-slots (direct-methods)
           specializer
         (or (cdr direct-methods)
             (setf (cdr direct-methods)
                   (gathering1 (collecting-once)
                          (dolist (m (car direct-methods))
                              (gather1 (method-generic-function m))))))))


;;; This hash table is used to store the direct methods and direct generic functions of EQL
;;; specializers.  Each value in the table is the cons. 


(defvar *eql-specializer-methods* (make-hash-table :test #'eql))

(defmethod add-method-on-specializer ((method method)
                                      (specializer eql-specializer))
       (let* ((object (eql-specializer-object specializer))
              (entry (gethash object *eql-specializer-methods*)))
             (unless entry
                 (setq entry (setf (gethash object *eql-specializer-methods*)
                                   (cons nil nil))))
             (setf (car entry)
                   (adjoin method (car entry))
                   (cdr entry)
                   nil)
             method))

(defmethod remove-method-on-specializer ((method method)
                                         (specializer eql-specializer))
       (let* ((object (eql-specializer-object specializer))
              (entry (gethash object *eql-specializer-methods*)))
             (when entry
                 (setf (car entry)
                       (remove method (car entry))
                       (cdr entry)
                       nil))
             method))

(defmethod specializer-methods ((specializer eql-specializer))
       (car (gethash (eql-specializer-object specializer)
                   *eql-specializer-methods*)))

(defmethod specializer-generic-functions ((specializer eql-specializer))
       (let* ((object (eql-specializer-object specializer))
              (entry (gethash object *eql-specializer-methods*)))
             (when entry
                 (or (cdr entry)
                     (setf (cdr entry)
                           (gathering1 (collecting-once)
                                  (dolist (m (car entry))
                                      (gather1 (method-generic-function m)))))))))

(defun real-load-defclass (name metaclass-name supers slots other accessors)
       (do-standard-defsetfs-for-defclass accessors)
                                                             ; ***
       (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots
              slots :definition-source `((defclass ,name ()
                                             ())
                                         ,(load-truename))
              other))

(defun ensure-class (name &rest all)
       (apply #'ensure-class-using-class name (find-class name nil)
              all))

(defmethod ensure-class-using-class (name (class null)
                                          &rest args &key)
       (multiple-value-bind (meta initargs)
           (ensure-class-values class args)
         (setf class (apply #'make-instance meta :name name initargs)
               (find-class name)
               class)
	 (inform-type-system-about-class class name)
                                                             ; ***
         class))

(defmethod ensure-class-using-class (name (class clos-class)
                                          &rest args &key)
       (multiple-value-bind (meta initargs)
           (ensure-class-values class args)
         (unless (eq (class-of class)
                     meta)
                (change-class class meta))
         (apply #'reinitialize-instance class initargs)
         (inform-type-system-about-class class name)
                                                             ; ***
         class))

(defun ensure-class-values (class args)
       (let* ((initargs (copy-list args))
              (unsupplied (list 1))
              (supplied-meta (getf initargs :metaclass unsupplied))
              (supplied-supers (getf initargs :direct-superclasses unsupplied))
              (supplied-slots (getf initargs :direct-slots unsupplied))
              (meta (cond ((neq supplied-meta unsupplied)
                           (find-class supplied-meta))
                          ((or (null class)
                               (forward-referenced-class-p class))
                           *the-class-standard-class*)
                          (t (class-of class))))
              (proto (class-prototype meta)))
             (flet ((fix-super (s)
                           (cond ((classp s)
                                  s)
                                 ((not (legal-class-name-p s))
                                  (error "~S is not a class or a legal class name." s))
                                 (t (or (find-class s nil)
                                        (setf (find-class s)
                                              (make-instance 'forward-referenced-class :name s)))))))
                   (loop (unless (remf initargs :metaclass)
                                (return)))
                   (loop (unless (remf initargs :direct-superclasses)
                                (return)))
                   (loop (unless (remf initargs :direct-slots)
                                (return)))
                   (values meta (list* :direct-superclasses (and (neq supplied-supers unsupplied)
                                                                 (mapcar #'fix-super supplied-supers)
                                                                 )
                                       :direct-slots
                                       (and (neq supplied-slots unsupplied)
                                            supplied-slots)
                                       initargs)))))


;;; 


(defmethod shared-initialize :before ((class std-class)
                                      slot-names &key direct-superclasses)
       (declare (ignore slot-names))
       
       ;; *** error checking
       )

(defmethod shared-initialize :after ((class std-class)
                                     slot-names 
				     &key (direct-superclasses 
					   nil direct-superclasses-p)
                                     (direct-slots nil direct-slots-p)
                                     (direct-default-initargs 
				      nil direct-default-initargs-p))
  (declare (ignore slot-names))
  (setq direct-superclasses (if direct-superclasses-p
				(setf (slot-value class 'direct-superclasses)
				      (or direct-superclasses 
					  (list *the-class-standard-object*)
					  ))
				(slot-value class 'direct-superclasses)))
  (setq direct-slots (if direct-slots-p
			 (setf (slot-value class 'direct-slots)
			       (mapcar #'(lambda (pl)
					   (make-direct-slotd class pl))
				       direct-slots))
			 (slot-value class 'direct-slots)))
  (if direct-default-initargs-p
      (setf (plist-value class 'direct-default-initargs)
	    direct-default-initargs)
      (setq direct-default-initargs
	    (plist-value class 'direct-default-initargs)))
  (setf (plist-value class 'class-slot-cells)
	(gathering1 (collecting)
                    (dolist (dslotd direct-slots)
		      (when (eq (slotd-allocation dslotd)
				class)
			(let ((initfunction (slotd-initfunction dslotd)))
			  (gather1 (cons (slotd-name dslotd)
					 (if initfunction
					     (funcall initfunction)
					     *slot-unbound*))))))))
  (add-direct-subclasses class direct-superclasses)
  (add-slot-accessors class direct-slots))

(defmethod reinitialize-instance :before ((class std-class)
                                          &key direct-superclasses direct-slots 
                                          direct-default-initargs)
       (declare (ignore direct-default-initargs))
       (remove-direct-subclasses class (class-direct-superclasses class))
       (remove-slot-accessors class (class-direct-slots class)))

(defmethod reinitialize-instance :after ((class std-class)
                                         &rest initargs &key)
       (update-class class nil)
       (map-dependents class #'(lambda (dependent)
                                      (apply #'update-dependent class dependent initargs))))

(defun add-slot-accessors (class dslotds)
       (fix-slot-accessors class dslotds 'add))

(defun remove-slot-accessors (class dslotds)
       (fix-slot-accessors class dslotds 'remove))

(defun fix-slot-accessors (class dslotds add/remove)
       (flet ((fix (gfspec name r/w)
                   (let ((gf (ensure-generic-function gfspec)))
                        (case r/w
                            (r (if (eq add/remove 'add)
                                   (add-reader-method class gf name)
                                   (remove-reader-method class gf)))
                            (w (if (eq add/remove 'add)
                                   (add-writer-method class gf name)
                                   (remove-writer-method class gf)))))))
             (dolist (dslotd dslotds)
                 (let ((slot-name (slotd-name dslotd)))
                      (dolist (r (slotd-readers dslotd))
                          (fix r slot-name 'r))
                      (dolist (w (slotd-writers dslotd))
                          (fix w slot-name 'w))))))

(defun add-direct-subclasses (class new)
       (dolist (n new)
           (unless (memq class (class-direct-subclasses class))
                  (add-direct-subclass n class))))

(defun remove-direct-subclasses (class new)
       (let ((old (class-direct-superclasses class)))
            (dolist (o (set-difference old new))
                (remove-direct-subclass o class))))


;;; 


(defmethod finalize-inheritance ((class std-class))
       (update-class class t))


;;; Called by :after reinitialize instance whenever a class is reinitialized. The class may or may
;;; not be finalized. 


(defun update-class (class finalizep)
       (when (or finalizep (class-finalized-p class))
           (let* ((dsupers (class-direct-superclasses class))
                  (dslotds (class-direct-slots class))
                  (dinits (class-direct-default-initargs class))
                  (cpl (compute-class-precedence-list class dsupers))
                  (eslotds (compute-slots class cpl dslotds))
                  (inits (compute-default-initargs class cpl dinits)))
                 (update-cpl class cpl)
                 (update-slots class cpl eslotds)
		 (update-dinits class dinits)
                 (update-inits class inits)
                 (update-constructors class)))
       (unless finalizep
           (dolist (sub (class-direct-subclasses class))
               (update-class sub nil))))

(defun update-cpl (class cpl)
       (when (class-finalized-p class)
           (unless (equal (class-precedence-list class)
                          cpl)
                  (force-cache-flushes class)))
       (setf (slot-value class 'class-precedence-list)
             cpl))

(defun update-slots (class cpl eslotds)
       (multiple-value-bind (nlayout nwrapper-class-slots)
           (compute-storage-info cpl eslotds)
         
         ;; If there is a change in the shape of the instances then the old class is now obsolete. 
         (let* ((owrapper (class-wrapper class))
                (olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
                (owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
                (nwrapper (cond ((null owrapper)
                                 (make-wrapper class))
                                ((and (equal nlayout olayout)
                                      (not (iterate ((o (list-elements owrapper-class-slots))
                                                     (n (list-elements nwrapper-class-slots)))
                                                  (unless (eq (car o)
                                                              (car n))
                                                         (return t)))))
                                 owrapper)
                                (t 

                                 ;; This will initialize the new wrapper to have the same state as
                                 ;; the old wrapper.  We will then have to change that.  This may
                                 ;; seem like wasted work (it is), but the spec requires that we
                                 ;; call make-instances-obsolete. 
                                   (make-instances-obsolete class)
                                   (class-wrapper class)))))
               (with-slots (wrapper no-of-instance-slots slots)
                   class
                 (setf no-of-instance-slots (length nlayout)
                       slots eslotds (wrapper-instance-slots-layout nwrapper)
                       nlayout
                       (wrapper-class-slots nwrapper)
                       nwrapper-class-slots wrapper nwrapper))
               (dolist (eslotd eslotds)
                   (setf (slotd-class eslotd)
                         class)
                   (setf (slotd-instance-index eslotd)
                         (instance-slot-index nwrapper (slotd-name eslotd)))))))

(defun compute-storage-info (cpl eslotds)
       (let ((instance nil)
             (class nil))
            (dolist (eslotd eslotds)
                (let ((alloc (slotd-allocation eslotd)))
                     (cond ((eq alloc :instance)
                            (push eslotd instance))
                           ((classp alloc)
                            (push eslotd class)))))
            (values (compute-layout cpl instance)
                   (compute-class-slots class))))

(defun compute-layout (cpl instance-eslotds)
       (let* ((names (gathering1 (collecting)
                            (dolist (eslotd instance-eslotds)
                                (when (eq (slotd-allocation eslotd)
                                          :instance)
                                    (gather1 (slotd-name eslotd))))))
              (order nil))
             (labels ((rwalk (tail)
                             (when tail
                                 (rwalk (cdr tail))
                                 (dolist (ss (class-slots (car tail)))
                                     (let ((n (slotd-name ss)))
                                          (when (memq n names)
                                              (setq order (cons n order)
                                                    names
                                                    (remove n names))))))))
                    (rwalk cpl)
                    (reverse (append names order)))))

(defun compute-class-slots (eslotds)
       (gathering1 (collecting)
              (dolist (eslotd eslotds)
                  (gather1 (assoc (slotd-name eslotd)
                                  (class-slot-cells (slotd-allocation eslotd)))))))
(defun update-dinits (class dinits)
  (setf (plist-value class 'direct-default-initargs) 
	(remove-invalid dinits (class-slots class))))

(defun update-inits (class inits)
       (setf (plist-value class 'default-initargs) 
	     (remove-invalid inits (class-slots class))))

;; bug: :default-initargs aren't updated with slots are removed, so
;; update-inits removes initargs that don't have corresponding slots.

(defun remove-invalid (inits slotds &aux (return nil))
  (dolist (element inits)
    (dolist (slotd slotds)
      (if (member (car element) (slot-value slotd 'initargs))
	  (pushnew element return))))
  return)



(defmethod compute-default-initargs ((class std-class)
                                     cpl direct)
       (labels ((walk (tail)
                      (if (null tail)
                          nil
                          (let ((c (pop tail)))
                               (append (if (eq c class)
                                           direct
                                           (class-direct-default-initargs c))
                                      (walk tail))))))
              (let ((initargs (walk cpl)))
		(delete-duplicates initargs 
				   :test #'eq :key #'car :from-end t))))


;;; Protocols for constructing direct and effective slot definitions. 


(defmethod direct-slot-definition-class ((class std-class)
                                         initargs)
       (declare (ignore initargs))
       (find-class 'standard-direct-slot-definition))

(defun make-direct-slotd (class initargs)
       (let ((initargs (list* :class class initargs)))
            (apply #'make-instance (direct-slot-definition-class class initargs)
                   initargs)))


;;; 


(defmethod compute-slots ((class std-class)
                          cpl class-direct-slots)
       
       ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once for each different slot
       ;; name we find in our superclasses.  Each call receives the class and a list of the dslotds
       ;; with that name. The list is in most-specific-first order. 
       (let ((name-dslotds-alist nil))
            (labels ((collect-one-class (dslotds)
                            (dolist (d dslotds)
                                (let* ((name (slotd-name d))
                                       (entry (assq name name-dslotds-alist)))
                                      (if entry
                                          (push d (cdr entry))
                                          (push (list name d)
                                                name-dslotds-alist))))))
                   (collect-one-class class-direct-slots)
                   (dolist (c (cdr cpl))
                       (collect-one-class (class-direct-slots c)))
                   (mapcar #'(lambda (direct)
                                    (compute-effective-slot-definition class (nreverse (cdr direct)))
                                    )
                          name-dslotds-alist))))

(defmethod compute-effective-slot-definition ((class std-class)
                                              dslotds)
       (let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
              (class (effective-slot-definition-class class initargs)))
             (apply #'make-instance class initargs)))

(defmethod effective-slot-definition-class ((class std-class)
                                            initargs)
       (declare (ignore initargs))
       (find-class 'standard-effective-slot-definition))

(defmethod compute-effective-slot-definition-initargs ((class std-class)
                                                       direct-slotds)
       (let* ((name nil)
              (initfunction nil)
              (initform nil)
              (initargs nil)
              (allocation nil)
              (type t)
              (namep nil)
              (initp nil)
              (allocp nil))
             (dolist (slotd direct-slotds)
                 (when slotd
                     (unless namep
                         (setq name (slotd-name slotd)
                               namep t))
                     (unless initp
                         (when (slotd-initfunction slotd)
                             (setq initform (slotd-initform slotd)
                                   initfunction
                                   (slotd-initfunction slotd)
                                   initp t)))
                     (unless allocp
                         (setq allocation (slotd-allocation slotd)
                               allocp t))
                     (setq initargs (append (slotd-initargs slotd)
                                           initargs))
                     (let ((slotd-type (slotd-type slotd)))
                          (setq type (cond ((null type)
                                            slotd-type)
                                           ((subtypep type slotd-type)
                                            type)
                                           (t `(and ,type ,slotd-type)))))))
             (list :name name :initform initform :initfunction initfunction :initargs initargs 
                   :allocation allocation :type type)))


;;; NOTE: For bootstrapping considerations, these can't use make-instance to make the method object.
;;; They have to use make-a-method which is a specially bootstrapped mechanism for making standard
;;; methods. 


(defmethod add-reader-method ((class std-class)
                              generic-function slot-name)
       (let* ((name (class-name class))
              (method (make-a-method 'standard-reader-method nil (list (or name 'standard-object))
                             (list class)
                             (make-reader-method-function class slot-name)
                             "automatically generated reader method" slot-name)))
             (add-method generic-function method)))

(defmethod add-writer-method ((class std-class)
                              generic-function slot-name)
       (let* ((name (class-name class))
              (method (make-a-method 'standard-writer-method nil (list 'new-value (or name
                                                                                      
                                                                                      '
                                                                                      standard-object
                                                                                      ))
                             (list *the-class-t* class)
                             (make-writer-method-function class slot-name)
                             "automatically generated writer method" slot-name)))
             (add-method generic-function method)))

(defmethod remove-reader-method ((class std-class)
                                 generic-function)
       (let ((method (get-method generic-function nil (list class)
                            nil)))
            (when method (remove-method generic-function method))))

(defmethod remove-writer-method ((class std-class)
                                 generic-function)
       (let ((method (get-method generic-function nil (list *the-class-t* class)
                            nil)))
            (when method (remove-method generic-function method))))


;;; make-reader-method-function and make-write-method function are NOT part of the standard
;;; protocol.  They are however useful, CLOS makes uses makes use of them internally and documents
;;; them for CLOS users. *** This needs work to make type testing by the writer functions which ***
;;; do type testing faster.  The idea would be to have one constructor *** for each possible type
;;; test.  In order to do this it would be nice *** to have help from inform-type-system-about-class
;;; and friends. *** There is a subtle bug here which is going to have to be fixed. *** Namely, the
;;; simplistic use of the template has to be fixed.  We *** have to give the optimize-slot-value
;;; method the user might have *** defined for this metclass a chance to run. 


(defmethod make-reader-method-function ((class standard-class)
                                        slot-name)
       (make-std-reader-method-function slot-name))

(defmethod make-writer-method-function ((class standard-class)
                                        slot-name)
       (make-std-writer-method-function slot-name))

(defun make-std-reader-method-function (slot-name)
       #'(lambda (instance)
                (slot-value instance slot-name)))

(defun make-std-writer-method-function (slot-name)
       #'(lambda (nv instance)
                (setf (slot-value instance slot-name)
                      nv)))

                                                             ; inform-type-system-about-class
                                                             ; make-type-predicate 



;;; These are NOT part of the standard protocol.  They are internal mechanism which CLOS uses to
;;; *try* and tell the type system about class definitions. In a more fully integrated
;;; implementation of CLOS, the type system would know about class objects and class names in a more
;;; fundamental way and the mechanism used to inform the type system about new classes would be
;;; different. 


(defmethod inform-type-system-about-class ((class std-class)
                                           name)
       (let ((predicate-name (make-type-predicate-name name)))
            (setf (symbol-function predicate-name)
                  (make-type-predicate name))
            (do-satisfies-deftype name predicate-name)
	    (setf (gethash name lisp::*typep-hash-table*)
		  predicate-name))) ;makes typep significantly faster...

(defun make-type-predicate (name)
       #'(lambda (x)
                (not (null (memq (find-class name)
                                 (cond ((std-instance-p x)
                                        (class-precedence-list (std-instance-class x)))
                                       ((fsc-instance-p x)
                                        (class-precedence-list (fsc-instance-class x)))))))))


;;; These 4 definitions appear here for bootstrapping reasons.  Logically, they should be in the
;;; construct file.  For documentation purposes, a copy of these definitions appears in the
;;; construct file.  If you change one of the definitions here, be sure to change the copy there. 


(defvar *initialization-generic-functions* (list #'make-instance #'default-initargs 
                                                 #'allocate-instance #'initialize-instance
                                                 #'shared-initialize))

(defmethod maybe-update-constructors ((generic-function generic-function)
                                      (method method))
       (when (memq generic-function *initialization-generic-functions*)
           (labels ((recurse (class)
                           (update-constructors class)
                           (dolist (subclass (class-direct-subclasses class))
                               (recurse subclass))))
                  (when (classp (car (method-specializers method)))
                      (recurse (car (method-specializers method)))))))

(defmethod update-constructors ((class std-class))
       (dolist (cons (class-constructors class))
           (install-lazy-constructor-installer cons)))

(defmethod update-constructors ((class class))
       nil)

(defmethod compatible-meta-class-change-p (class proto-new-class)
       (eq (class-of class)
           (class-of proto-new-class)))

(defmethod check-super-metaclass-compatibility ((class t)
                                                (new-super t))
       (unless (eq (class-of class)
                   (class-of new-super))
           (error "The class ~S was specified as a~%super-class of the class ~S;~%~
            but the meta-classes ~S and~%~S are incompatible." new-super class (class-of new-super)
                  (class-of class))))


;;; 


(defun force-cache-flushes (class)
       (let* ((owrapper (class-wrapper class))
              (state (wrapper-state owrapper)))
             
             ;; We only need to do something if the state is still T.  If the state isn't T, it 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. 
             (when (eq state 't)
                 (let ((nwrapper (make-wrapper class)))
                      (setf (wrapper-instance-slots-layout nwrapper)
                            (wrapper-instance-slots-layout owrapper))
                      (setf (wrapper-class-slots nwrapper)
                            (wrapper-class-slots owrapper))
                      (without-interrupts (setf (slot-value class 'wrapper)
                                                nwrapper)
                             (invalidate-wrapper owrapper 'flush nwrapper))
                      (update-constructors class)))))

                                                             ; ??? ***


(defun flush-cache-trap (owrapper nwrapper instance)
       (declare (ignore owrapper))
       (set-wrapper instance nwrapper))


;;; make-instances-obsolete can be called by user code.  It will cause the next access to the
;;; instance (as defined in 88-002R) to trap through the update-instance-for-redefined-class
;;; mechanism. 


(defmethod make-instances-obsolete ((class std-class))
       (let ((owrapper (class-wrapper class))
             (nwrapper (make-wrapper class)))
            (setf (wrapper-instance-slots-layout nwrapper)
                  (wrapper-instance-slots-layout owrapper))
            (setf (wrapper-class-slots nwrapper)
                  (wrapper-class-slots owrapper))
            (without-interrupts (setf (slot-value class 'wrapper)
                                      nwrapper)
                   (invalidate-wrapper owrapper 'obsolete nwrapper)
                   class)))

(defmethod make-instances-obsolete ((class symbol))
       (make-instances-obsolete (find-class class)))


;;; obsolete-instance-trap is the internal trap that is called when we see an obsolete instance. 
;;; The times when it is called are: - when the instance is involved in method lookup - when
;;; attempting to access a slot of an instance It is not called by class-of, wrapper-of, or any of
;;; the low-level instance access macros. Of course these times when it is called are an internal
;;; implementation detail of CLOS and are not part of the documented description of when the obsolete
;;; instance update happens.  The documented description is as it appears in 88-002R. This has to
;;; return the new wrapper, so it counts on all the methods on obsolete-instance-trap-internal to
;;; return the new wrapper.  It also does a little internal error checking to make sure that the
;;; traps are only happening when they should, and that the trap methods are computing apropriate
;;; new wrappers. 


(defun obsolete-instance-trap (owrapper nwrapper instance)
       
       ;; local  --> local        transfer local  --> shared       discard local  -->  --         
       ;; discard shared --> local        transfer shared --> shared       discard shared -->  --   
       ;; discard --    --> local        add --    --> shared        -- 
       (let* ((class (wrapper-class nwrapper))
              (guts (allocate-instance class))
                                                             ; ??? allocate-instance ???
              (olayout (wrapper-instance-slots-layout owrapper))
              (nlayout (wrapper-instance-slots-layout nwrapper))
              (oslots (get-slots instance))
              (nslots (get-slots guts))
              (oclass-slots (wrapper-class-slots owrapper))
              (added nil)
              (discarded nil)
              (plist nil))
             
             ;; Go through all the old local slots. 
             (iterate ((name (list-elements olayout))
                       (opos (interval :from 0)))
                    (let ((npos (posq name nlayout)))
                         (if npos
                             (setf (svref nslots npos)
                                   (svref oslots opos))
                             (progn (push name discarded)
                                    (unless (eq (svref oslots opos)
                                                *slot-unbound*)
                                        (setf (getf plist name)
                                              (svref oslots opos)))))))
             
             ;; Go through all the old shared slots. 
             (iterate ((oclass-slot-and-val (list-elements oclass-slots)))
                    (let ((name (car oclass-slot-and-val))
                          (val (cdr oclass-slot-and-val)))
                         (let ((npos (posq name nlayout)))
                              (if npos
                                  (setf (svref nslots npos)
                                        (cdr oclass-slot-and-val))
                                  (progn (push name discarded)
                                         (unless (eq val *slot-unbound*)
                                             (setf (getf plist name)
                                                   val)))))))
             
             ;; Go through all the new local slots to compute the added slots. 
             (dolist (nlocal nlayout)
                 (unless (or (memq nlocal olayout)
                             (assq nlocal oclass-slots))
                        (push nlocal added)))
             (without-interrupts (set-wrapper instance nwrapper)
                    (set-slots instance nslots))
             (update-instance-for-redefined-class instance added discarded plist)
             nwrapper))


;;; 


(defmacro change-class-internal (wrapper-fetcher slots-fetcher alloc)
       `(let* ((old-class (class-of instance))
               (copy (,alloc old-class))
               (guts (,alloc new-class))
               (new-wrapper (,wrapper-fetcher guts))
               (old-wrapper (class-wrapper old-class))
               (old-layout (wrapper-instance-slots-layout old-wrapper))
               (new-layout (wrapper-instance-slots-layout new-wrapper))
               (old-slots (,slots-fetcher instance))
               (new-slots (,slots-fetcher guts))
               (old-class-slots (wrapper-class-slots old-wrapper)))
              
              ;; "The values of local slots specified by both the class Cto and Cfrom are retained. 
              ;; If such a local slot was unbound, it remains unbound." 
              (iterate ((new-slot (list-elements new-layout))
                        (new-position (interval :from 0)))
                     (let ((old-position (position new-slot old-layout :test #'eq)))
                          (when old-position
                              (setf (svref new-slots new-position)
                                    (svref old-slots old-position)))))
              
              ;; "The values of slots specified as shared in the class Cfrom and as local in the
              ;; class Cto are retained." 
              (iterate ((slot-and-val (list-elements old-class-slots)))
                     (let ((position (position (car slot-and-val)
                                            new-layout :test #'eq)))
                          (when position
                              (setf (svref new-slots position)
                                    (cdr slot-and-val)))))
              
              ;; Make the copy point to the old instance's storage, and make the old instance point
              ;; to the new storage. 
              (without-interrupts (setf (,slots-fetcher copy)
                                        old-slots)
                     (setf (,wrapper-fetcher instance)
                           new-wrapper)
                     (setf (,slots-fetcher instance)
                           new-slots))
              (update-instance-for-different-class copy instance)
              instance))

(defmethod change-class ((instance standard-object)
                         (new-class standard-class))
       (unless (std-instance-p instance)
           (error "Can't change the class of ~S to ~S~@
            because it isn't already an instance with metaclass~%~S." instance new-class 
                  'standard-class))
       (change-class-internal std-instance-wrapper std-instance-slots allocate-instance))

(defmethod change-class ((instance standard-object)
                         (new-class funcallable-standard-class))
       (unless (fsc-instance-p instance)
           (error "Can't change the class of ~S to ~S~@
            because it isn't already an instance with metaclass~%~S." instance new-class 
                  'funcallable-standard-class))
       (change-class-internal fsc-instance-wrapper fsc-instance-slots allocate-instance))

(defmethod change-class ((instance t)
                         (new-class-name symbol))
       (change-class instance (find-class new-class-name)))


;;; The metaclass BUILT-IN-CLASS This metaclass is something of a weird creature.  By this point,
;;; all instances of it which will exist have been created, and no instance is ever created by
;;; calling MAKE-INSTANCE. But, there are other parts of the protcol we must follow and those
;;; definitions appear here. 


(defmethod shared-initialize :before ((class built-in-class)
                                      slot-names &rest initargs)
       (declare (ignore slot-names))
       (error "Attempt to initialize or reinitialize a built in class."))

(defmethod class-direct-slots ((class built-in-class))
       nil)

(defmethod class-slots ((class built-in-class))
       nil)

(defmethod class-direct-default-initargs ((class built-in-class))
       nil)

(defmethod class-default-initargs ((class built-in-class))
       nil)

(defmethod check-super-metaclass-compatibility ((c class)
                                                (s built-in-class))
       (or (eq s *the-class-t*)
           (error "~S cannot have ~S as a super.~%~
              The class ~S is the only built in class that can be a~%~
              superclass of a standard class." c s *the-class-t*)))


;;; 


(defmethod check-super-metaclass-compatibility ((c std-class)
                                                (f forward-referenced-class))
       't)


;;; 


(defmethod add-dependent ((metaobject dependent-update-mixin)
                          dependent)
       (pushnew dependent (plist-value metaobject 'dependents)))

(defmethod remove-dependent ((metaobject dependent-update-mixin)
                             dependent)
       (setf (plist-value metaobject 'dependents)
             (delete dependent (plist-value metaobject 'dependents))))

(defmethod map-dependents ((metaobject dependent-update-mixin)
                           function)
       (dolist (dependent (plist-value metaobject 'dependents))
           (funcall function dependent)))