src/pcl/std-class.lisp

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