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 26(defmethod slot-accessor-function ((slotd effective-slot-definition) type) 27 (let ((info (the slot-info (slot-definition-info slotd)))) 28 (ecase type 29 (reader (slot-info-reader info)) 30 (writer (slot-info-writer info)) 31 (boundp (slot-info-boundp info))))) 32 33(defmethod (setf slot-accessor-function) (function 34 (slotd effective-slot-definition) 35 type) 36 (let ((info (the slot-info (slot-definition-info slotd)))) 37 (ecase type 38 (reader (setf (slot-info-reader info) function)) 39 (writer (setf (slot-info-writer info) function)) 40 (boundp (setf (slot-info-boundp info) function))))) 41 42(defconstant +slotd-reader-function-std-p+ 1) 43(defconstant +slotd-writer-function-std-p+ 2) 44(defconstant +slotd-boundp-function-std-p+ 4) 45(defconstant +slotd-all-function-std-p+ 7) 46 47(defmethod slot-accessor-std-p ((slotd effective-slot-definition) type) 48 (let ((flags (slot-value slotd 'accessor-flags))) 49 (declare (type fixnum flags)) 50 (if (eq type 'all) 51 (eql +slotd-all-function-std-p+ flags) 52 (logtest flags (ecase type 53 (reader +slotd-reader-function-std-p+) 54 (writer +slotd-writer-function-std-p+) 55 (boundp +slotd-boundp-function-std-p+)))))) 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 (logior (logandc2 flags mask) (if value mask 0)))) 68 value) 69 70(defmethod initialize-internal-slot-functions 71 ((slotd effective-slot-definition)) 72 (let* ((name (slot-value slotd 'name)) ; flushable? (is it ever unbound?) 73 (class (slot-value slotd '%class))) 74 (declare (ignore name)) 75 (dolist (type '(reader writer boundp)) 76 (let* ((gf-name (ecase type 77 (reader 'slot-value-using-class) 78 (writer '(setf slot-value-using-class)) 79 (boundp 'slot-boundp-using-class))) 80 (gf (gdefinition gf-name))) 81 ;; KLUDGE: this logic is cut'n'pasted from 82 ;; GET-ACCESSOR-METHOD-FUNCTION, which (for STD-CLASSes) is 83 ;; only called later, because it does things that can't be 84 ;; computed this early in class finalization; however, we need 85 ;; this bit as early as possible. -- CSR, 2009-11-05 86 (setf (slot-accessor-std-p slotd type) 87 (let* ((types1 `((eql ,class) (class-eq ,class) (eql ,slotd))) 88 (types (if (eq type 'writer) `(t ,@types1) types1)) 89 (methods (compute-applicable-methods-using-types gf types))) 90 (null (cdr methods)))) 91 (setf (slot-accessor-function slotd type) 92 (lambda (&rest args) 93 (declare (dynamic-extent args)) 94 ;; FIXME: a tiny amount of wasted SLOT-ACCESSOR-STD-P 95 ;; work here (see KLUDGE comment above). 96 (let ((fun (compute-slot-accessor-info slotd type gf))) 97 (apply fun args)))))))) 98 99(defmethod finalize-internal-slot-functions ((slotd effective-slot-definition)) 100 (dolist (type '(reader writer boundp)) 101 (let* ((gf-name (ecase type 102 (reader 'slot-value-using-class) 103 (writer '(setf slot-value-using-class)) 104 (boundp 'slot-boundp-using-class))) 105 (gf (gdefinition gf-name))) 106 (compute-slot-accessor-info slotd type gf)))) 107 108;;; CMUCL (Gerd PCL 2003-04-25) comment: 109;;; 110;;; Compute an effective method for SLOT-VALUE-USING-CLASS, (SETF 111;;; SLOT-VALUE-USING-CLASS) or SLOT-BOUNDP-USING-CLASS for reading/ 112;;; writing/testing effective slot SLOTD. 113;;; 114;;; TYPE is one of the symbols READER, WRITER or BOUNDP, depending on 115;;; GF. Store the effective method in the effective slot definition 116;;; object itself; these GFs have special dispatch functions calling 117;;; effective methods directly retrieved from effective slot 118;;; definition objects, as an optimization. 119;;; 120;;; FIXME: Change the function name to COMPUTE-SVUC-SLOTD-FUNCTION, 121;;; or some such. 122(defmethod compute-slot-accessor-info ((slotd effective-slot-definition) 123 type gf) 124 (let* ((name (slot-value slotd 'name)) ; flushable? 125 (class (slot-value slotd '%class))) 126 (declare (ignore name)) 127 (multiple-value-bind (function std-p) 128 (if (eq **boot-state** 'complete) 129 (get-accessor-method-function gf type class slotd) 130 (get-optimized-std-accessor-method-function class slotd type)) 131 (setf (slot-accessor-std-p slotd type) std-p) 132 (setf (slot-accessor-function slotd type) function)))) 133 134(defmethod slot-definition-allocation ((slotd structure-slot-definition)) 135 :instance) 136 137;;;; various class accessors that are a little more complicated than can be 138;;;; done with automatically generated reader methods 139 140(defmethod class-prototype :before (class) 141 (unless (class-finalized-p class) 142 (error "~@<~S is not finalized.~:@>" class))) 143 144;;; KLUDGE: For some reason factoring the common body into a function 145;;; breaks PCL bootstrapping, so just generate it with a macrolet for 146;;; all. 147(macrolet ((def (class) 148 `(defmethod class-prototype ((class ,class)) 149 (declare (notinline allocate-instance)) 150 (with-slots (prototype) class 151 (or prototype 152 (setf prototype (allocate-instance class))))))) 153 (def std-class) 154 (def condition-class) 155 (def structure-class)) 156 157(defmethod class-direct-default-initargs ((class slot-class)) 158 (plist-value class 'direct-default-initargs)) 159 160(defmethod class-default-initargs ((class slot-class)) 161 (plist-value class 'default-initargs)) 162 163(defmethod class-slot-cells ((class std-class)) 164 (plist-value class 'class-slot-cells)) 165(defmethod (setf class-slot-cells) (new-value (class std-class)) 166 (setf (plist-value class 'class-slot-cells) new-value)) 167 168;;;; class accessors that are even a little bit more complicated than those 169;;;; above. These have a protocol for updating them, we must implement that 170;;;; protocol. 171 172;;; Maintaining the direct subclasses backpointers. The update methods are 173;;; here, the values are read by an automatically generated reader method. 174(defmethod add-direct-subclass ((class class) (subclass class)) 175 (with-slots (direct-subclasses) class 176 (pushnew subclass direct-subclasses :test #'eq) 177 subclass)) 178(defmethod remove-direct-subclass ((class class) (subclass class)) 179 (with-slots (direct-subclasses) class 180 (setq direct-subclasses (remove subclass direct-subclasses)) 181 subclass)) 182 183;;; Maintaining the direct-methods and direct-generic-functions backpointers. 184;;; 185;;; There are four generic functions involved, each has one method. All of 186;;; these are specified methods and appear in their specified place in the 187;;; class graph. 188;;; 189;;; ADD-DIRECT-METHOD 190;;; REMOVE-DIRECT-METHOD 191;;; SPECIALIZER-DIRECT-METHODS 192;;; SPECIALIZER-DIRECT-GENERIC-FUNCTIONS 193;;; 194;;; In each case, we maintain one value which is a cons. The car is the list 195;;; of methods. The cdr is a list of the generic functions. The cdr is always 196;;; computed lazily. 197 198;;; This needs to be used recursively, in case a non-trivial user 199;;; defined ADD/REMOVE-DIRECT-METHOD method ends up calling another 200;;; function using the same lock. 201(defvar *specializer-lock* (sb-thread:make-mutex :name "Specializer lock")) 202 203(defmethod add-direct-method :around ((specializer specializer) method) 204 ;; All the actions done under this lock are done in an order 205 ;; that is safe to unwind at any point. 206 (sb-thread::with-recursive-system-lock (*specializer-lock*) 207 (call-next-method))) 208 209(defmethod remove-direct-method :around ((specializer specializer) method) 210 ;; All the actions done under this lock are done in an order 211 ;; that is safe to unwind at any point. 212 (sb-thread::with-recursive-system-lock (*specializer-lock*) 213 (call-next-method))) 214 215(defmethod add-direct-method ((specializer specializer) (method method)) 216 (let ((cell (specializer-method-holder specializer))) 217 ;; We need to first smash the CDR, because a parallel read may 218 ;; be in progress, and because if an interrupt catches us we 219 ;; need to have a consistent state. 220 (setf (cdr cell) () 221 (car cell) (adjoin method (car cell) :test #'eq))) 222 method) 223 224(defmethod remove-direct-method ((specializer specializer) (method method)) 225 (let ((cell (specializer-method-holder specializer))) 226 ;; We need to first smash the CDR, because a parallel read may 227 ;; be in progress, and because if an interrupt catches us we 228 ;; need to have a consistent state. 229 (setf (cdr cell) () 230 (car cell) (remove method (car cell)))) 231 method) 232 233(defmethod specializer-direct-methods ((specializer specializer)) 234 (car (specializer-method-holder specializer nil))) 235 236(defmethod specializer-direct-generic-functions ((specializer specializer)) 237 (let ((cell (specializer-method-holder specializer nil))) 238 ;; If an ADD/REMOVE-METHOD is in progress, no matter: either 239 ;; we behave as if we got just first or just after -- it's just 240 ;; for update that we need to lock. 241 (or (cdr cell) 242 (when (car cell) 243 (setf (cdr cell) 244 (sb-thread:with-mutex (*specializer-lock*) 245 (let (collect) 246 (dolist (m (car cell) (nreverse collect)) 247 ;; the old PCL code used COLLECTING-ONCE which used 248 ;; #'EQ to check for newness 249 (pushnew (method-generic-function m) collect 250 :test #'eq))))))))) 251 252(defmethod specializer-method-holder ((self specializer) &optional create) 253 ;; CREATE can be ignored, because instances of SPECIALIZER 254 ;; other than CLASS-EQ-SPECIALIZER have their DIRECT-METHODS slot 255 ;; preinitialized with (NIL . NIL). 256 (declare (ignore create)) 257 (slot-value self 'direct-methods)) 258 259;; Same as for CLASS but the only ancestor it shares is SPECIALIZER. 260;; If this were defined on SPECIALIZER-WITH-OBJECT then it would 261;; apply as well to CLASS-EQ specializers which we don't want. 262(defmethod specializer-method-holder ((self eql-specializer) &optional create) 263 (declare (ignore create)) 264 (slot-value self 'direct-methods)) 265 266;;; This hash table is used to store the direct methods and direct generic 267;;; functions of CLASS-EQ specializers. 268;;; This is needed because CLASS-EQ specializers are not interned: two different 269;;; specializers could refer to the identical CLASS. But semantically you don't 270;;; want to collect the direct methods separately, you want them all together. 271;;; So a logical place to do that would be in the CLASS. We could add another 272;;; slot to CLASS holding the CLASS-EQ-DIRECT-METHODS. I guess the idea though 273;;; is to be able to define other kinds of specializers that hold an object 274;;; where you don't have the ability to add a slot to that object. 275;;; So that's fine, you look up the object in this table, and the approach 276;;; generalizes by defining other tables similarly, but has the same problem 277;;; of garbage retention as did EQL specializers. 278;;; I suspect CLASS-EQ specializers aren't used enough to worry about. 279;;; 280;;; This table is shared between threads, so needs to be synchronized. 281;;; (though insertions are only performed when holding the specializer-lock, 282;;; so the preceding claim is probably overly paranoid.) 283(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq :synchronized t)) 284 285(defmethod specializer-method-table ((specializer class-eq-specializer)) 286 *class-eq-specializer-methods*) 287 288(defmethod specializer-method-holder ((self specializer-with-object) 289 &optional (create t)) 290 (let ((table (specializer-method-table self)) 291 (object (specializer-object self))) 292 (if create 293 (sb-impl::puthash-if-absent object table (lambda () (cons nil nil))) 294 (gethash object table)))) 295 296(defun map-specializers (function) 297 (map-all-classes (lambda (class) 298 (funcall function (class-eq-specializer class)) 299 (funcall function class))) 300 (maphash (lambda (object specl) 301 (declare (ignore object)) 302 (funcall function specl)) 303 *eql-specializer-table*) 304 nil) 305 306(defun map-all-generic-functions (function) 307 (let ((all-generic-functions (make-hash-table :test 'eq))) 308 (map-specializers (lambda (specl) 309 (dolist (gf (specializer-direct-generic-functions 310 specl)) 311 (unless (gethash gf all-generic-functions) 312 (setf (gethash gf all-generic-functions) t) 313 (funcall function gf)))))) 314 nil) 315 316(defmethod shared-initialize :after ((specl class-eq-specializer) 317 slot-names 318 &key) 319 (declare (ignore slot-names)) 320 (setf (slot-value specl '%type) `(class-eq ,(specializer-class specl)))) 321 322(defmethod shared-initialize :after ((specl eql-specializer) slot-names &key) 323 (declare (ignore slot-names)) 324 (setf (slot-value specl '%type) 325 `(eql ,(specializer-object specl)))) 326 327(defun real-load-defclass (name metaclass-name supers slots other 328 readers writers slot-names source-location &optional safe-p) 329 (sb-kernel::call-with-defining-class 330 'class name 331 (lambda () 332 (sb-kernel::%%compiler-defclass name readers writers slot-names) 333 (apply #'ensure-class name :metaclass metaclass-name 334 :direct-superclasses supers 335 :direct-slots slots 336 :definition-source source-location 337 'safe-p safe-p 338 other)))) 339 340(setf (gdefinition 'load-defclass) #'real-load-defclass) 341 342(defun ensure-class (name &rest args) 343 (with-world-lock () 344 (apply #'ensure-class-using-class 345 (let ((class (find-class name nil))) 346 (when (and class (eq name (class-name class))) 347 ;; NAME is the proper name of CLASS, so redefine it 348 class)) 349 name args))) 350 351(defun parse-ensure-class-args (class name args) 352 (let ((metaclass *the-class-standard-class*) 353 (metaclassp nil) 354 (reversed-plist '())) 355 (labels ((find-class* (which class-or-name) 356 (cond 357 ((classp class-or-name) 358 (cond 359 ((eq class-or-name class) 360 (error "~@<Class ~A specified as its own ~ 361 ~(~A~)class.~@:>" 362 class-or-name which)) 363 (t 364 class-or-name))) 365 ((and class-or-name (legal-class-name-p class-or-name)) 366 (cond 367 ((eq class-or-name name) 368 (error "~@<Class named ~ 369 ~/sb-impl::print-symbol-with-prefix/ ~ 370 specified as its own ~(~A~)class.~@:>" 371 class-or-name which)) 372 ((find-class class-or-name (eq which :meta))) 373 ((ensure-class 374 class-or-name :metaclass 'forward-referenced-class)))) 375 (t 376 (error "~@<Not a class or a legal ~(~A~)class name: ~ 377 ~S.~@:>" 378 which class-or-name)))) 379 (find-superclass (class-or-name) 380 (find-class* :super class-or-name))) 381 (doplist (key value) args 382 (case key 383 (:metaclass 384 (unless metaclassp 385 (setf metaclass (find-class* :meta value) 386 metaclassp key))) 387 (:direct-superclasses 388 (let ((superclasses (mapcar #'find-superclass value))) 389 (setf reversed-plist (list* superclasses key reversed-plist)))) 390 (t 391 (setf reversed-plist (list* value key reversed-plist))))) 392 (values metaclass (nreverse reversed-plist))))) 393 394(defun call-with-ensure-class-context (class name args thunk) 395 (let ((class (with-world-lock () 396 (multiple-value-bind (metaclass initargs) 397 (parse-ensure-class-args class name args) 398 (let ((class (funcall thunk class name metaclass initargs))) 399 (without-package-locks 400 (setf (find-class name) class))))))) 401 class)) 402 403(defmethod ensure-class-using-class ((class null) name &rest args &key) 404 (call-with-ensure-class-context 405 class name args (lambda (class name metaclass initargs) 406 (declare (ignore class)) 407 (apply #'make-instance metaclass :name name initargs)))) 408 409(defmethod ensure-class-using-class ((class pcl-class) name &rest args &key) 410 (call-with-ensure-class-context 411 class name args (lambda (class name metaclass initargs) 412 (aver (eq name (class-name class))) 413 (unless (eq (class-of class) metaclass) 414 (apply #'change-class class metaclass initargs)) 415 (apply #'reinitialize-instance class initargs) 416 class))) 417 418;;; This is used to call initfunctions of :allocation :class slots. 419(defun call-initfun (fun slotd safe) 420 (declare (function fun)) 421 (let ((value (funcall fun))) 422 (when safe 423 (let ((type (slot-definition-type slotd))) 424 (unless (or (eq t type) 425 (typep value type)) 426 (error 'type-error :expected-type type :datum value)))) 427 value)) 428 429(defmethod shared-initialize :after 430 ((class std-class) slot-names &key 431 (direct-superclasses nil direct-superclasses-p) 432 (direct-slots nil direct-slots-p) 433 (direct-default-initargs nil direct-default-initargs-p)) 434 (cond (direct-superclasses-p 435 (setq direct-superclasses 436 (or direct-superclasses 437 (list (if (funcallable-standard-class-p class) 438 *the-class-funcallable-standard-object* 439 *the-class-standard-object*)))) 440 (dolist (superclass direct-superclasses) 441 (unless (validate-superclass class superclass) 442 (invalid-superclass class superclass))) 443 (setf (slot-value class 'direct-superclasses) direct-superclasses)) 444 (t 445 (setq direct-superclasses (slot-value class 'direct-superclasses)))) 446 (setq direct-slots 447 (if direct-slots-p 448 (setf (slot-value class 'direct-slots) 449 (mapcar (lambda (pl) (make-direct-slotd class pl)) 450 direct-slots)) 451 (slot-value class 'direct-slots))) 452 (if direct-default-initargs-p 453 (setf (plist-value class 'direct-default-initargs) 454 direct-default-initargs) 455 (setq direct-default-initargs 456 (plist-value class 'direct-default-initargs))) 457 (setf (plist-value class 'class-slot-cells) 458 (let ((old-class-slot-cells (plist-value class 'class-slot-cells)) 459 (safe (safe-p class)) 460 (collect '())) 461 (dolist (dslotd direct-slots) 462 (when (eq :class (slot-definition-allocation dslotd)) 463 ;; see CLHS 4.3.6 464 (let* ((name (slot-definition-name dslotd)) 465 (old (assoc name old-class-slot-cells))) 466 (if (or (not old) 467 (eq t slot-names) 468 (member name slot-names :test #'eq)) 469 (let* ((initfunction (slot-definition-initfunction dslotd)) 470 (value 471 (if initfunction 472 (call-initfun initfunction dslotd safe) 473 +slot-unbound+))) 474 (push (cons name value) collect)) 475 (push old collect))))) 476 (nreverse collect))) 477 (add-direct-subclasses class direct-superclasses) 478 (if (class-finalized-p class) 479 ;; required by AMOP, "Reinitialization of Class Metaobjects" 480 (finalize-inheritance class) 481 (update-class class nil)) 482 (add-slot-accessors class direct-slots) 483 (make-preliminary-layout class)) 484 485(define-condition invalid-superclass (reference-condition error) 486 ((class :initarg :class :reader invalid-superclass-class) 487 (superclass :initarg :superclass :reader invalid-superclass-superclass)) 488 (:report 489 (lambda (c s) 490 (let ((class (invalid-superclass-class c)) 491 (superclass (invalid-superclass-superclass c))) 492 (format s 493 "~@<The class ~S was specified as a superclass of the ~ 494 class ~S, but the metaclasses ~S and ~S are ~ 495 incompatible.~@[ Define a method for ~S to avoid this ~ 496 error.~]~@:>" 497 superclass class (class-of superclass) (class-of class) 498 (and (typep superclass 'standard-class) 499 'validate-superclass)))))) 500 501(defmethod invalid-superclass ((class class) (superclass class)) 502 (error 'invalid-superclass :class class :superclass superclass 503 :references (list* '(:amop :generic-function validate-superclass) 504 (and (typep superclass 'built-in-class) 505 (list '(:ansi-cl :system-class built-in-class) 506 '(:ansi-cl :section (4 3 7))))))) 507 508(defmethod shared-initialize :after ((class forward-referenced-class) 509 slot-names &key &allow-other-keys) 510 (declare (ignore slot-names)) 511 (make-preliminary-layout class)) 512 513(defvar *allow-forward-referenced-classes-in-cpl-p* nil) 514 515;;; Give CLASS a preliminary layout if it doesn't have one already, to 516;;; make it known to the type system. 517(defun make-preliminary-layout (class) 518 (flet ((compute-preliminary-cpl (root) 519 (let ((*allow-forward-referenced-classes-in-cpl-p* t)) 520 (compute-class-precedence-list root)))) 521 (with-world-lock () 522 (without-package-locks 523 (unless (class-finalized-p class) 524 (let ((name (class-name class))) ; flushable? 525 (declare (ignore name)) 526 ;; KLUDGE: This is fairly horrible. We need to make a 527 ;; full-fledged CLASSOID here, not just tell the compiler that 528 ;; some class is forthcoming, because there are legitimate 529 ;; questions one can ask of the type system, implemented in 530 ;; terms of CLASSOIDs, involving forward-referenced classes. So. 531 (let ((layout (make-wrapper 0 class))) 532 (setf (slot-value class 'wrapper) layout) 533 (let ((cpl (compute-preliminary-cpl class))) 534 (setf (layout-inherits layout) 535 (order-layout-inherits 536 (map 'simple-vector #'class-wrapper 537 (reverse (rest cpl)))))) 538 (register-layout layout :invalidate t)))) 539 (mapc #'make-preliminary-layout (class-direct-subclasses class)))))) 540 541 542(defmethod shared-initialize :before ((class class) slot-names &key name) 543 (declare (ignore slot-names name)) 544 ;; FIXME: Could this just be CLASS instead of `(CLASS ,CLASS)? If not, 545 ;; why not? (See also similar expression in !BOOTSTRAP-INITIALIZE-CLASS.) 546 (setf (slot-value class '%type) `(class ,class)) 547 (setf (slot-value class 'class-eq-specializer) 548 (make-instance 'class-eq-specializer :class class))) 549 550(defmethod reinitialize-instance :before ((class slot-class) &key direct-superclasses) 551 (dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses)) 552 (remove-direct-subclass old-super class)) 553 (remove-slot-accessors class (class-direct-slots class))) 554 555(defmethod reinitialize-instance :after ((class slot-class) 556 &rest initargs 557 &key) 558 (map-dependents class 559 (lambda (dependent) 560 (apply #'update-dependent class dependent initargs)))) 561 562(defmethod reinitialize-instance :after ((class condition-class) &key) 563 (let* ((name (class-name class)) 564 (classoid (find-classoid name)) 565 (slots (condition-classoid-slots classoid)) 566 (source (sb-kernel::layout-source-location (classoid-layout classoid)))) 567 ;; to balance the REMOVE-SLOT-ACCESSORS call in 568 ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS). 569 (flet ((add-source-location (method) 570 (when source 571 (setf (slot-value method 'source) source)))) 572 (dolist (slot slots) 573 (let ((slot-name (condition-slot-name slot))) 574 (dolist (reader (condition-slot-readers slot)) 575 ;; FIXME: see comment in SHARED-INITIALIZE :AFTER 576 ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18 577 (add-source-location 578 (sb-kernel::install-condition-slot-reader reader name slot-name))) 579 (dolist (writer (condition-slot-writers slot)) 580 (add-source-location 581 (sb-kernel::install-condition-slot-writer writer name slot-name)))))))) 582 583(defmethod shared-initialize :after ((class condition-class) slot-names 584 &key direct-slots direct-superclasses) 585 (declare (ignore slot-names)) 586 (let ((classoid (find-classoid (slot-value class 'name)))) 587 (with-slots (wrapper 588 %class-precedence-list cpl-available-p finalized-p 589 prototype (direct-supers direct-superclasses) 590 plist) 591 class 592 (setf (slot-value class 'direct-slots) 593 (mapcar (lambda (pl) (make-direct-slotd class pl)) 594 direct-slots) 595 finalized-p t 596 (classoid-pcl-class classoid) class 597 direct-supers direct-superclasses 598 wrapper (classoid-layout classoid) 599 %class-precedence-list (compute-class-precedence-list class) 600 cpl-available-p t 601 (getf plist 'direct-default-initargs) 602 (sb-kernel::condition-classoid-direct-default-initargs classoid)) 603 (add-direct-subclasses class direct-superclasses) 604 (let ((slots (compute-slots class))) 605 (setf (slot-value class 'slots) slots) 606 (setf (layout-slot-table wrapper) (make-slot-table class slots))))) 607 ;; Comment from Gerd's PCL, 2003-05-15: 608 ;; 609 ;; We don't ADD-SLOT-ACCESSORS here because we don't want to 610 ;; override condition accessors with generic functions. We do this 611 ;; differently. 612 ;; 613 ;; ??? What does the above comment mean and why is it a good idea? 614 ;; CMUCL (which still as of 2005-11-18 uses this code and has this 615 ;; comment) loses slot information in its condition classes: 616 ;; DIRECT-SLOTS is always NIL. We have the right information, so we 617 ;; remove slot accessors but never put them back. I've added a 618 ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what 619 ;; was meant to happen? -- CSR, 2005-11-18 620 ) 621 622(defmethod direct-slot-definition-class ((class condition-class) 623 &rest initargs) 624 (declare (ignore initargs)) 625 (find-class 'condition-direct-slot-definition)) 626 627(defmethod effective-slot-definition-class ((class condition-class) 628 &rest initargs) 629 (declare (ignore initargs)) 630 (find-class 'condition-effective-slot-definition)) 631 632(defmethod finalize-inheritance ((class condition-class)) 633 (aver (slot-value class 'finalized-p)) 634 nil) 635 636(defmethod compute-effective-slot-definition 637 ((class condition-class) slot-name dslotds) 638 (let* ((slotd (call-next-method)) 639 (info (slot-definition-info slotd))) 640 (setf (slot-info-reader info) 641 (lambda (x) 642 (handler-case (condition-reader-function x slot-name) 643 ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot 644 ;; is unbound; maybe it should be a CELL-ERROR of some 645 ;; sort? 646 (error () (values (slot-unbound class x slot-name)))))) 647 (setf (slot-info-writer info) 648 (lambda (v x) 649 (condition-writer-function x v slot-name))) 650 (setf (slot-info-boundp info) 651 (lambda (x) 652 (multiple-value-bind (v c) 653 (ignore-errors (condition-reader-function x slot-name)) 654 (declare (ignore v)) 655 (null c)))) 656 slotd)) 657 658(defmethod compute-slots :around ((class condition-class)) 659 (let ((eslotds (call-next-method))) 660 (mapc #'finalize-internal-slot-functions eslotds) 661 eslotds)) 662 663(defmethod shared-initialize :after 664 ((slotd structure-slot-definition) slot-names &key 665 (allocation :instance) allocation-class) 666 (declare (ignore slot-names allocation-class)) 667 (unless (eq allocation :instance) 668 (error "Structure slots must have :INSTANCE allocation."))) 669 670(defun make-structure-class-defstruct-form (name direct-slots include) 671 (let* ((conc-name (format-symbol *package* "~S structure class " name)) 672 (constructor (format-symbol *package* "~Aconstructor" conc-name)) 673 (included-name (class-name include)) 674 (included-slots 675 (when include 676 (mapcar #'dsd-name (dd-slots (find-defstruct-description included-name))))) 677 (old-slots nil) 678 (new-slots nil) 679 (reader-names nil) 680 (writer-names nil)) 681 (dolist (slotd (reverse direct-slots)) 682 (let* ((slot-name (slot-definition-name slotd)) 683 (initform (slot-definition-initform slotd)) 684 (type (slot-definition-type slotd)) 685 (desc `(,slot-name ,initform :type ,type))) 686 (push `(slot-accessor ,name ,slot-name reader) 687 reader-names) 688 (push `(slot-accessor ,name ,slot-name writer) 689 writer-names) 690 (if (member slot-name included-slots :test #'eq) 691 (push desc old-slots) 692 (push desc new-slots)))) 693 (let* ((defstruct `(defstruct (,name 694 ,@(when include 695 `((:include ,included-name 696 ,@old-slots))) 697 (:constructor ,constructor ()) 698 (:predicate nil) 699 (:conc-name ,conc-name) 700 (:copier nil)) 701 ,@new-slots)) 702 (readers-init 703 (mapcar (lambda (slotd reader-name) 704 (let ((accessor 705 (slot-definition-defstruct-accessor-symbol 706 slotd))) 707 `(defun ,reader-name (obj) 708 (declare (type ,name obj)) 709 (,accessor obj)))) 710 direct-slots reader-names)) 711 (writers-init 712 (mapcar (lambda (slotd writer-name) 713 (let ((accessor 714 (slot-definition-defstruct-accessor-symbol 715 slotd))) 716 `(defun ,writer-name (nv obj) 717 (declare (type ,name obj)) 718 (setf (,accessor obj) nv)))) 719 direct-slots writer-names)) 720 (defstruct-form 721 `(progn 722 ,defstruct 723 ,@readers-init ,@writers-init 724 (cons nil nil)))) 725 (values defstruct-form constructor reader-names writer-names)))) 726 727;;; Return a thunk to allocate an instance of CLASS named NAME. 728;;; This is broken with regard to the expectation that all semantic 729;;; processing is done by the compiler. e.g. after COMPILE-FILE on 730;;; a file containing these two toplevel forms: 731;;; (eval-when (:compile-toplevel) (defmacro maker () '(list 1))) 732;;; (defstruct foo (a (maker))) 733;;; then LOADing the resulting fasl in a fresh image will err: 734;;; (make-instance 'foo) => "The function MAKER is undefined." 735;;; 736;;; The way to fix that is to ensure that every defstruct has a zero-argument 737;;; constructor made by the compiler and stashed in a random symbol. 738(defun make-defstruct-allocation-function (name class) 739 (declare (muffle-conditions code-deletion-note)) 740 ;; FIXME: Why don't we go class->layout->info == dd 741 (let ((dd (find-defstruct-description name))) 742 (ecase (dd-type dd) 743 (structure 744 ;; This used to call COMPILE directly, which is basically pointless, 745 ;; because it certainly does not avoid compiling code at runtime, 746 ;; which seems to have been the goal. We're also compiling: 747 ;; (LAMBDA () (SB-PCL::FAST-MAKE-INSTANCE #<STRUCTURE-CLASS THING>)) 748 ;; So maybe we can figure out how to bundle two lambdas together? 749 (lambda () 750 (let* ((dd (layout-info (class-wrapper class))) 751 (f (%make-structure-instance-allocator dd nil))) 752 (if (functionp f) 753 (funcall (setf (slot-value class 'defstruct-constructor) f)) 754 (error "Can't allocate ~S" class))))) 755 (funcallable-structure 756 ;; FIXME: you can't dynamically define new funcallable structures 757 ;; that are not GENERIC-FUNCTION subtypes, so why this branch? 758 ;; We should pull this out, fixup PCL bootstrap, and not pretend 759 ;; that this code is more general than it really is. 760 (%make-funcallable-structure-instance-allocator dd nil))))) 761 762(defmethod shared-initialize :after 763 ((class structure-class) slot-names &key 764 (direct-superclasses nil direct-superclasses-p) 765 (direct-slots nil direct-slots-p) 766 direct-default-initargs) 767 (declare (ignore slot-names direct-default-initargs)) 768 (if direct-superclasses-p 769 (setf (slot-value class 'direct-superclasses) 770 (or direct-superclasses 771 (setq direct-superclasses 772 (and (not (eq (slot-value class 'name) 'structure-object)) 773 (list *the-class-structure-object*))))) 774 (setq direct-superclasses (slot-value class 'direct-superclasses))) 775 (let* ((name (slot-value class 'name)) 776 (from-defclass-p (slot-value class 'from-defclass-p)) 777 ;; DEFSTRUCT-P means we should perform the effect of DEFSTRUCT, 778 ;; and not that this structure came from a DEFSTRUCT. 779 (defstruct-p (or from-defclass-p (not (structure-type-p name))))) 780 (if direct-slots-p 781 (setf (slot-value class 'direct-slots) 782 (setq direct-slots 783 (mapcar (lambda (pl) 784 (when defstruct-p 785 (let* ((slot-name (getf pl :name)) 786 (accessor 787 (format-symbol *package* 788 "~S structure class ~A" 789 name slot-name))) 790 (setq pl (list* :defstruct-accessor-symbol 791 accessor pl)))) 792 (make-direct-slotd class pl)) 793 direct-slots))) 794 (setq direct-slots (slot-value class 'direct-slots))) 795 (if defstruct-p 796 (let ((include (car (slot-value class 'direct-superclasses)))) 797 (multiple-value-bind (defstruct-form constructor reader-names writer-names) 798 (make-structure-class-defstruct-form name direct-slots include) 799 (unless (structure-type-p name) (eval defstruct-form)) 800 (mapc (lambda (dslotd reader-name writer-name) 801 (let* ((reader (gdefinition reader-name)) 802 (writer (when (fboundp writer-name) 803 (gdefinition writer-name)))) 804 (setf (slot-value dslotd 'internal-reader-function) 805 reader) 806 (setf (slot-value dslotd 'internal-writer-function) 807 writer))) 808 direct-slots reader-names writer-names) 809 (setf (slot-value class 'defstruct-form) defstruct-form) 810 (setf (slot-value class 'defstruct-constructor) constructor))) 811 ;; FIXME: If we always need a default constructor, then why not just make 812 ;; a "hidden" one at actual-compile-time and store it? 813 ;; And this is very broken with regard to the lexical environment. 814 ;; And why isn't this just DD-DEFAULT-CONSTRUCTOR if there was one? 815 (setf (slot-value class 'defstruct-constructor) 816 ;; KLUDGE: not class; in fixup.lisp, can't access slots 817 ;; outside methods yet. 818 (make-defstruct-allocation-function name class))) 819 (add-direct-subclasses class direct-superclasses) 820 (setf (slot-value class '%class-precedence-list) 821 (compute-class-precedence-list class)) 822 (setf (slot-value class 'cpl-available-p) t) 823 (let ((slots (compute-slots class))) 824 (setf (slot-value class 'slots) slots) 825 (let* ((lclass (find-classoid (slot-value class 'name))) 826 (layout (classoid-layout lclass))) 827 (setf (classoid-pcl-class lclass) class) 828 (setf (slot-value class 'wrapper) layout) 829 (setf (layout-slot-table layout) (make-slot-table class slots)))) 830 (setf (slot-value class 'finalized-p) t) 831 (add-slot-accessors class direct-slots))) 832 833(defmethod direct-slot-definition-class ((class structure-class) &rest initargs) 834 (declare (ignore initargs)) 835 (find-class 'structure-direct-slot-definition)) 836 837(defmethod finalize-inheritance ((class structure-class)) 838 nil) ; always finalized 839 840(defun add-slot-accessors (class dslotds) 841 (fix-slot-accessors class dslotds 'add)) 842 843(defun remove-slot-accessors (class dslotds) 844 (fix-slot-accessors class dslotds 'remove)) 845 846(defun fix-slot-accessors (class dslotds add/remove) 847 (flet ((fix (gfspec name r/w doc source-location) 848 (let ((gf (cond ((eq add/remove 'add) 849 (or (find-generic-function gfspec nil) 850 (ensure-generic-function 851 gfspec :lambda-list (case r/w 852 (r '(object)) 853 (w '(new-value object)))))) 854 (t 855 (find-generic-function gfspec nil))))) 856 (when gf 857 (case r/w 858 (r (if (eq add/remove 'add) 859 (add-reader-method class gf name doc source-location) 860 (remove-reader-method class gf))) 861 (w (if (eq add/remove 'add) 862 (add-writer-method class gf name doc source-location) 863 (remove-writer-method class gf)))))))) 864 (dolist (dslotd dslotds) 865 (let ((slot-name (slot-definition-name dslotd)) 866 (slot-doc (%slot-definition-documentation dslotd)) 867 (location (definition-source dslotd))) 868 (dolist (r (slot-definition-readers dslotd)) 869 (fix r slot-name 'r slot-doc location)) 870 (dolist (w (slot-definition-writers dslotd)) 871 (fix w slot-name 'w slot-doc location)))))) 872 873(defun add-direct-subclasses (class supers) 874 (dolist (super supers) 875 (unless (memq class (class-direct-subclasses class)) 876 (add-direct-subclass super class)))) 877 878(defmethod finalize-inheritance ((class std-class)) 879 (update-class class t)) 880 881(defmethod finalize-inheritance ((class forward-referenced-class)) 882 ;; FIXME: should we not be thinking a bit about what kinds of error 883 ;; we're throwing? Maybe we need a clos-error type to mix in? Or 884 ;; possibly a forward-referenced-class-error, though that's 885 ;; difficult given e.g. class precedence list calculations... 886 (error 887 "~@<FINALIZE-INHERITANCE was called on a forward referenced class:~ 888 ~2I~_~S~:>" 889 class)) 890 891 892(defun class-has-a-forward-referenced-superclass-p (class) 893 (or (when (forward-referenced-class-p class) 894 class) 895 (some #'class-has-a-forward-referenced-superclass-p 896 (class-direct-superclasses class)))) 897 898;;; This is called by :after shared-initialize whenever a class is initialized 899;;; or reinitialized. The class may or may not be finalized. 900(defun update-class (class finalizep) 901 (labels ((rec (class finalizep &optional (seen '())) 902 (when (find class seen :test #'eq) 903 (error "~@<Specified class ~S as a superclass of ~ 904 itself.~@:>" 905 class)) 906 (without-package-locks 907 (with-world-lock () 908 (when (or finalizep (class-finalized-p class)) 909 (%update-cpl class (compute-class-precedence-list class)) 910 ;; This invocation of UPDATE-SLOTS, in practice, finalizes the 911 ;; class 912 (%update-slots class (compute-slots class)) 913 (update-gfs-of-class class) 914 (setf (plist-value class 'default-initargs) (compute-default-initargs class)) 915 (update-ctors 'finalize-inheritance :class class)) 916 (let ((seen (list* class seen))) 917 (dolist (sub (class-direct-subclasses class)) 918 (rec sub nil seen))))))) 919 (rec class finalizep))) 920 921(define-condition cpl-protocol-violation (reference-condition error) 922 ((class :initarg :class :reader cpl-protocol-violation-class) 923 (cpl :initarg :cpl :reader cpl-protocol-violation-cpl)) 924 (:default-initargs :references (list '(:sbcl :node "Metaobject Protocol"))) 925 (:report 926 (lambda (c s) 927 (format s "~@<Protocol violation: the ~S class ~S ~ 928 ~:[has~;does not have~] the class ~S in its ~ 929 class precedence list: ~S.~@:>" 930 (class-name (class-of (cpl-protocol-violation-class c))) 931 (cpl-protocol-violation-class c) 932 (eq (class-of (cpl-protocol-violation-class c)) 933 *the-class-funcallable-standard-class*) 934 (find-class 'function) 935 (cpl-protocol-violation-cpl c))))) 936 937(defun class-has-a-cpl-protocol-violation-p (class) 938 (labels ((find-in-superclasses (class classes) 939 (cond 940 ((null classes) nil) 941 ((eql class (car classes)) t) 942 (t (find-in-superclasses class (append (class-direct-superclasses (car classes)) (cdr classes))))))) 943 (let ((metaclass (class-of class))) 944 (cond 945 ((eql metaclass *the-class-standard-class*) 946 (find-in-superclasses (find-class 'function) (list class))) 947 ((eql metaclass *the-class-funcallable-standard-class*) 948 (not (find-in-superclasses (find-class 'function) (list class)))))))) 949 950(defun %update-cpl (class cpl) 951 (when (or (and 952 (eq (class-of class) *the-class-standard-class*) 953 (find *the-class-function* cpl)) 954 (and (eq (class-of class) *the-class-funcallable-standard-class*) 955 (not (and (find (find-class 'function) cpl))))) 956 (error 'cpl-protocol-violation :class class :cpl cpl)) 957 (cond ((not (class-finalized-p class)) 958 (setf (slot-value class '%class-precedence-list) cpl 959 (slot-value class 'cpl-available-p) t)) 960 ((not (and (equal (class-precedence-list class) cpl) 961 (dolist (c cpl t) 962 (when (position :class (class-direct-slots c) 963 :key #'slot-definition-allocation) 964 (return nil))))) 965 966 ;; comment from the old CMU CL sources: 967 ;; Need to have the cpl setup before %update-lisp-class-layout 968 ;; is called on CMU CL. 969 (setf (slot-value class '%class-precedence-list) cpl 970 (slot-value class 'cpl-available-p) t) 971 (%force-cache-flushes class))) 972 (update-class-can-precede-p cpl)) 973 974(defun update-class-can-precede-p (cpl) 975 (when cpl 976 (let ((first (car cpl))) 977 (dolist (c (cdr cpl)) 978 (pushnew c (slot-value first 'can-precede-list) :test #'eq))) 979 (update-class-can-precede-p (cdr cpl)))) 980 981(defun class-can-precede-p (class1 class2) 982 (member class2 (class-can-precede-list class1) :test #'eq)) 983 984;;; This is called from %UPDATE-SLOTS to check if slot layouts are compatible. 985;;; 986;;; In addition to slot locations (implicit in the ordering of the slots), we 987;;; must check classes: SLOT-INFO structures from old slotds may have been 988;;; cached in permutation vectors, but new slotds have had new ones allocated 989;;; to them. This is non-problematic for standard slotds, because we know the 990;;; structure is compatible, but if a slot definition class changes, this can 991;;; change the way SLOT-VALUE-USING-CLASS should dispatch. 992;;; 993;;; Also, if the slot has a non-standard allocation, we need to check that it 994;;; doesn't change. 995(defun slot-layouts-compatible-p 996 (oslotds new-instance-slotds new-class-slotds new-custom-slotds) 997 (multiple-value-bind (old-instance-slotds old-class-slotds old-custom-slotds) 998 (classify-slotds oslotds) 999 (and 1000 ;; Instance slots: name, type, and class. 1001 (dolist (o old-instance-slotds (not new-instance-slotds)) 1002 (let ((n (pop new-instance-slotds))) 1003 (unless (and n 1004 (eq (slot-definition-name o) (slot-definition-name n)) 1005 (eq (slot-definition-type o) (slot-definition-type n)) 1006 (eq (class-of o) (class-of n))) 1007 (return nil)))) 1008 ;; Class slots: name and class. (FIXME: class slots not typechecked?) 1009 (dolist (o old-class-slotds (not new-class-slotds)) 1010 (let ((n (pop new-class-slotds))) 1011 (unless (and n 1012 (eq (slot-definition-name o) (slot-definition-name n)) 1013 (eq (class-of n) (class-of o))) 1014 (return nil)))) 1015 ;; Custom slots: check name, type, allocation, and class. (FIXME: should we just punt?) 1016 (dolist (o old-custom-slotds (not new-custom-slotds)) 1017 (let ((n (pop new-custom-slotds))) 1018 (unless (and n 1019 (eq (slot-definition-name o) (slot-definition-name n)) 1020 (eq (slot-definition-type o) (slot-definition-type n)) 1021 (eq (slot-definition-allocation o) (slot-definition-allocation n)) 1022 (eq (class-of o) (class-of n))) 1023 (return nil))))))) 1024 1025(defun style-warn-about-duplicate-slots (class) 1026 (do* ((slots (slot-value class 'slots) (cdr slots)) 1027 (dupes nil)) 1028 ((null slots) 1029 (when dupes 1030 (style-warn 1031 "~@<slot names with the same SYMBOL-NAME but ~ 1032 different SYMBOL-PACKAGE (possible package problem) ~ 1033 for class ~S:~4I~@:_~<~@{~/sb-impl::print-symbol-with-prefix/~^~:@_~}~:>~@:>" 1034 class dupes))) 1035 (let* ((slot-name (slot-definition-name (car slots))) 1036 (oslots (and (not (eq (symbol-package slot-name) 1037 *pcl-package*)) 1038 (remove-if 1039 (lambda (slot-name-2) 1040 (or (eq (symbol-package slot-name-2) 1041 *pcl-package*) 1042 (string/= slot-name slot-name-2))) 1043 (cdr slots) 1044 :key #'slot-definition-name)))) 1045 (when oslots 1046 (pushnew (cons slot-name 1047 (mapcar #'slot-definition-name oslots)) 1048 dupes 1049 :test #'string= :key #'car))))) 1050 1051(defun %update-slots (class eslotds) 1052 (multiple-value-bind (instance-slots class-slots custom-slots) 1053 (classify-slotds eslotds) 1054 (let* ((nslots (length instance-slots)) 1055 (owrapper (class-wrapper class)) 1056 (nwrapper 1057 (cond ((and owrapper 1058 (slot-layouts-compatible-p (layout-slot-list owrapper) 1059 instance-slots class-slots custom-slots)) 1060 owrapper) 1061 ((or (not owrapper) 1062 (not (class-finalized-p class))) 1063 (make-wrapper nslots class)) 1064 (t 1065 ;; This will initialize the new wrapper to have the 1066 ;; same state as the old wrapper. We will then have 1067 ;; to change that. This may seem like wasted work 1068 ;; (and it is), but the spec requires that we call 1069 ;; MAKE-INSTANCES-OBSOLETE. 1070 (make-instances-obsolete class) 1071 (class-wrapper class))))) 1072 (%update-lisp-class-layout class nwrapper) 1073 (setf (slot-value class 'slots) eslotds 1074 (layout-slot-list nwrapper) eslotds 1075 (layout-slot-table nwrapper) (make-slot-table class eslotds) 1076 (layout-length nwrapper) nslots 1077 (slot-value class 'wrapper) nwrapper) 1078 (style-warn-about-duplicate-slots class) 1079 (setf (slot-value class 'finalized-p) t) 1080 (unless (eq owrapper nwrapper) 1081 (maybe-update-standard-slot-locations class))))) 1082 1083(defun update-gf-dfun (class gf) 1084 (let ((*new-class* class) 1085 (arg-info (gf-arg-info gf))) 1086 (cond 1087 ((special-case-for-compute-discriminating-function-p gf)) 1088 ((gf-precompute-dfun-and-emf-p arg-info) 1089 (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf) 1090 (update-dfun gf dfun cache info)))))) 1091 1092(defun update-gfs-of-class (class) 1093 (when (and (class-finalized-p class) 1094 (let ((cpl (class-precedence-list class))) 1095 (or (member *the-class-slot-class* cpl :test #'eq) 1096 (member *the-class-standard-effective-slot-definition* 1097 cpl :test #'eq)))) 1098 (let ((gf-table (make-hash-table :test 'eq))) 1099 (labels ((collect-gfs (class) 1100 (dolist (gf (specializer-direct-generic-functions class)) 1101 (setf (gethash gf gf-table) t)) 1102 (mapc #'collect-gfs (class-direct-superclasses class)))) 1103 (collect-gfs class) 1104 (maphash (lambda (gf ignore) 1105 (declare (ignore ignore)) 1106 (update-gf-dfun class gf)) 1107 gf-table))))) 1108 1109(defmethod compute-default-initargs ((class slot-class)) 1110 (let ((initargs (loop for c in (class-precedence-list class) 1111 append (class-direct-default-initargs c)))) 1112 (delete-duplicates initargs :test #'eq :key #'car :from-end t))) 1113 1114;;;; protocols for constructing direct and effective slot definitions 1115 1116(defmethod direct-slot-definition-class ((class std-class) &rest initargs) 1117 (declare (ignore initargs)) 1118 (find-class 'standard-direct-slot-definition)) 1119 1120(defun make-direct-slotd (class initargs) 1121 (apply #'make-instance 1122 (apply #'direct-slot-definition-class class initargs) 1123 :class class 1124 initargs)) 1125 1126;;; I (CSR) am not sure, but I believe that the particular order of 1127;;; slots is quite important: it is ideal to attempt to have a 1128;;; constant slot location for the same notional slots as much as 1129;;; possible, so that clever discriminating functions (ONE-INDEX et 1130;;; al.) have a chance of working. The below at least walks through 1131;;; the slots predictably, but maybe it would be good to compute some 1132;;; kind of optimal slot layout by looking at locations of slots in 1133;;; superclasses? 1134(defun std-compute-slots (class) 1135 ;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once 1136 ;; for each different slot name we find in our superclasses. Each 1137 ;; call receives the class and a list of the dslotds with that name. 1138 ;; The list is in most-specific-first order. 1139 (let ((name-dslotds-alist ())) 1140 (dolist (c (reverse (class-precedence-list class))) 1141 (dolist (slot (class-direct-slots c)) 1142 (let* ((name (slot-definition-name slot)) 1143 (entry (assq name name-dslotds-alist))) 1144 (if entry 1145 (push slot (cdr entry)) 1146 (push (list name slot) name-dslotds-alist))))) 1147 (mapcar (lambda (direct) 1148 (compute-effective-slot-definition class 1149 (car direct) 1150 (cdr direct))) 1151 (nreverse name-dslotds-alist)))) 1152 1153;; It seems to me that this should be one method defined on SLOT-CLASS. 1154(defmethod compute-slots ((class standard-class)) 1155 (std-compute-slots class)) 1156(defmethod compute-slots ((class funcallable-standard-class)) 1157 (std-compute-slots class)) 1158(defmethod compute-slots ((class structure-class)) 1159 (std-compute-slots class)) 1160(defmethod compute-slots ((class condition-class)) 1161 (std-compute-slots class)) 1162 1163(defun std-compute-slots-around (class eslotds) 1164 (let ((location -1) 1165 (safe (safe-p class))) 1166 (dolist (eslotd eslotds eslotds) 1167 (setf (slot-definition-location eslotd) 1168 (case (slot-definition-allocation eslotd) 1169 (:instance 1170 (incf location)) 1171 (:class 1172 (let* ((name (slot-definition-name eslotd)) 1173 (from-class 1174 (or 1175 (slot-definition-allocation-class eslotd) 1176 ;; we get here if the user adds an extra slot 1177 ;; himself... 1178 (setf (slot-definition-allocation-class eslotd) 1179 class))) 1180 ;; which raises the question of what we should 1181 ;; do if we find that said user has added a slot 1182 ;; with the same name as another slot... 1183 (cell (or (assq name (class-slot-cells from-class)) 1184 (let ((c (cons name +slot-unbound+))) 1185 (push c (class-slot-cells from-class)) 1186 c)))) 1187 (aver (consp cell)) 1188 (if (eq +slot-unbound+ (cdr cell)) 1189 ;; We may have inherited an initfunction FIXME: Is this 1190 ;; really right? Is the initialization in 1191 ;; SHARED-INITIALIZE (STD-CLASS) not enough? 1192 (let ((initfun (slot-definition-initfunction eslotd))) 1193 (if initfun 1194 (rplacd cell (call-initfun initfun eslotd safe)) 1195 cell)) 1196 cell))))) 1197 (unless (slot-definition-class eslotd) 1198 (setf (slot-definition-class eslotd) class)) 1199 (initialize-internal-slot-functions eslotd)))) 1200 1201(defmethod compute-slots :around ((class standard-class)) 1202 (let ((eslotds (call-next-method))) 1203 (std-compute-slots-around class eslotds))) 1204(defmethod compute-slots :around ((class funcallable-standard-class)) 1205 (let ((eslotds (call-next-method))) 1206 (std-compute-slots-around class eslotds))) 1207(defmethod compute-slots :around ((class structure-class)) 1208 (let ((eslotds (call-next-method))) 1209 (mapc #'finalize-internal-slot-functions eslotds) 1210 eslotds)) 1211 1212(defmethod compute-effective-slot-definition ((class slot-class) name dslotds) 1213 (let* ((initargs (compute-effective-slot-definition-initargs class dslotds)) 1214 (class (apply #'effective-slot-definition-class class initargs)) 1215 (slotd (apply #'make-instance class initargs))) 1216 slotd)) 1217 1218(defmethod effective-slot-definition-class ((class std-class) &rest initargs) 1219 (declare (ignore initargs)) 1220 (find-class 'standard-effective-slot-definition)) 1221 1222(defmethod effective-slot-definition-class ((class structure-class) &rest initargs) 1223 (declare (ignore initargs)) 1224 (find-class 'structure-effective-slot-definition)) 1225 1226(defmethod compute-effective-slot-definition-initargs 1227 ((class slot-class) direct-slotds) 1228 (let* ((name nil) 1229 (initfunction nil) 1230 (initform nil) 1231 (initargs nil) 1232 (allocation nil) 1233 (allocation-class nil) 1234 (type t) 1235 (documentation nil) 1236 (documentationp nil) 1237 (namep nil) 1238 (initp nil) 1239 (allocp nil)) 1240 1241 (dolist (slotd direct-slotds) 1242 (when slotd 1243 (unless namep 1244 (setq name (slot-definition-name slotd) 1245 namep t)) 1246 (unless initp 1247 (awhen (slot-definition-initfunction slotd) 1248 (setq initform (slot-definition-initform slotd) 1249 initfunction it 1250 initp t))) 1251 (unless documentationp 1252 (awhen (%slot-definition-documentation slotd) 1253 (setq documentation it 1254 documentationp t))) 1255 (unless allocp 1256 (setq allocation (slot-definition-allocation slotd) 1257 allocation-class (slot-definition-class slotd) 1258 allocp t)) 1259 (setq initargs (append (slot-definition-initargs slotd) initargs)) 1260 (let ((slotd-type (slot-definition-type slotd))) 1261 (setq type (cond 1262 ((eq type t) slotd-type) 1263 ;; This pairwise type intersection is perhaps a 1264 ;; little inefficient and inelegant, but it's 1265 ;; unlikely to lie on the critical path. Shout 1266 ;; if I'm wrong. -- CSR, 2005-11-24 1267 (t (type-specifier 1268 (specifier-type `(and ,type ,slotd-type))))))))) 1269 (list :name name 1270 :initform initform 1271 :initfunction initfunction 1272 :initargs initargs 1273 :allocation allocation 1274 :allocation-class allocation-class 1275 :type type 1276 :class class 1277 :documentation documentation))) 1278 1279(defmethod compute-effective-slot-definition-initargs :around 1280 ((class structure-class) direct-slotds) 1281 (let* ((slotd (car direct-slotds)) 1282 (accessor (slot-definition-defstruct-accessor-symbol slotd))) 1283 (list* :defstruct-accessor-symbol accessor 1284 :internal-reader-function 1285 (slot-definition-internal-reader-function slotd) 1286 :internal-writer-function 1287 (slot-definition-internal-writer-function slotd) 1288 (call-next-method)))) 1289 1290;;; NOTE: For bootstrapping considerations, these can't use MAKE-INSTANCE 1291;;; to make the method object. They have to use make-a-method which 1292;;; is a specially bootstrapped mechanism for making standard methods. 1293(defmethod reader-method-class ((class slot-class) direct-slot &rest initargs) 1294 (declare (ignore direct-slot initargs)) 1295 (find-class 'standard-reader-method)) 1296 1297(defmethod add-reader-method ((class slot-class) generic-function slot-name slot-documentation source-location) 1298 (add-method generic-function 1299 (make-a-method 'standard-reader-method 1300 () 1301 (list (or (class-name class) 'object)) 1302 (list class) 1303 (make-reader-method-function class slot-name) 1304 (or slot-documentation "automatically generated reader method") 1305 :slot-name slot-name 1306 :object-class class 1307 :method-class-function #'reader-method-class 1308 :definition-source source-location))) 1309 1310(defmethod writer-method-class ((class slot-class) direct-slot &rest initargs) 1311 (declare (ignore direct-slot initargs)) 1312 (find-class 'standard-writer-method)) 1313 1314(defmethod add-writer-method ((class slot-class) generic-function slot-name slot-documentation source-location) 1315 (add-method generic-function 1316 (make-a-method 'standard-writer-method 1317 () 1318 (list 'new-value (or (class-name class) 'object)) 1319 (list *the-class-t* class) 1320 (make-writer-method-function class slot-name) 1321 (or slot-documentation "automatically generated writer method") 1322 :slot-name slot-name 1323 :object-class class 1324 :method-class-function #'writer-method-class 1325 :definition-source source-location))) 1326 1327(defmethod add-boundp-method ((class slot-class) generic-function slot-name slot-documentation source-location) 1328 (add-method generic-function 1329 (make-a-method (constantly (find-class 'standard-boundp-method)) 1330 class 1331 () 1332 (list (or (class-name class) 'object)) 1333 (list class) 1334 (make-boundp-method-function class slot-name) 1335 (or slot-documentation "automatically generated boundp method") 1336 :slot-name slot-name 1337 :definition-source source-location))) 1338 1339(defmethod remove-reader-method ((class slot-class) generic-function) 1340 (let ((method (get-method generic-function () (list class) nil))) 1341 (when method (remove-method generic-function method)))) 1342 1343(defmethod remove-writer-method ((class slot-class) generic-function) 1344 (let ((method 1345 (get-method generic-function () (list *the-class-t* class) nil))) 1346 (when method (remove-method generic-function method)))) 1347 1348(defmethod remove-boundp-method ((class slot-class) generic-function) 1349 (let ((method (get-method generic-function () (list class) nil))) 1350 (when method (remove-method generic-function method)))) 1351 1352;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION 1353;;; function are NOT part of the standard protocol. They are however 1354;;; useful; PCL makes use of them internally and documents them for 1355;;; PCL users. (FIXME: but SBCL certainly doesn't) 1356;;; 1357;;; *** This needs work to make type testing by the writer functions which 1358;;; *** do type testing faster. The idea would be to have one constructor 1359;;; *** for each possible type test. 1360;;; 1361;;; *** There is a subtle bug here which is going to have to be fixed. 1362;;; *** Namely, the simplistic use of the template has to be fixed. We 1363;;; *** have to give the OPTIMIZE-SLOT-VALUE method the user might have 1364;;; *** defined for this metaclass a chance to run. 1365 1366(defmethod make-reader-method-function ((class slot-class) slot-name) 1367 (make-std-reader-method-function class slot-name)) 1368 1369(defmethod make-writer-method-function ((class slot-class) slot-name) 1370 (make-std-writer-method-function class slot-name)) 1371 1372(defmethod make-boundp-method-function ((class slot-class) slot-name) 1373 (make-std-boundp-method-function class slot-name)) 1374 1375(defmethod compatible-meta-class-change-p (class proto-new-class) 1376 (eq (class-of class) (class-of proto-new-class))) 1377 1378(defmethod validate-superclass ((class class) (superclass class)) 1379 (or (eq (class-of class) (class-of superclass)) 1380 (and (eq (class-of superclass) *the-class-standard-class*) 1381 (eq (class-of class) *the-class-funcallable-standard-class*)) 1382 (and (eq (class-of superclass) *the-class-funcallable-standard-class*) 1383 (eq (class-of class) *the-class-standard-class*)))) 1384 1385;;; What this does depends on which of the four possible values of 1386;;; LAYOUT-INVALID the PCL wrapper has; the simplest case is when it 1387;;; is (:FLUSH <wrapper>) or (:OBSOLETE <wrapper>), when there is 1388;;; nothing to do, as the new wrapper has already been created. If 1389;;; LAYOUT-INVALID returns NIL, then we invalidate it (setting it to 1390;;; (:FLUSH <wrapper>); UPDATE-SLOTS later gets to choose whether or 1391;;; not to "upgrade" this to (:OBSOLETE <wrapper>). 1392;;; 1393;;; This leaves the case where LAYOUT-INVALID returns T, which happens 1394;;; when REGISTER-LAYOUT has invalidated a superclass of CLASS (which 1395;;; invalidated all the subclasses in SB-KERNEL land). Again, here we 1396;;; must flush the caches and allow UPDATE-SLOTS to decide whether to 1397;;; obsolete the wrapper. 1398;;; 1399;;; FIXME: either here or in INVALID-WRAPPER-P looks like a good place 1400;;; for (AVER (NOT (EQ (LAYOUT-INVALID OWRAPPER) 1401;;; :UNINITIALIZED))) 1402;;; 1403;;; Thanks to Gerd Moellmann for the explanation. -- CSR, 2002-10-29 1404(defun %force-cache-flushes (class) 1405 (with-world-lock () 1406 (let* ((owrapper (class-wrapper class))) 1407 ;; We only need to do something if the wrapper is still valid. If 1408 ;; the wrapper isn't valid, state will be FLUSH or OBSOLETE, and 1409 ;; both of those will already be doing what we want. In 1410 ;; particular, we must be sure we never change an OBSOLETE into a 1411 ;; FLUSH since OBSOLETE means do what FLUSH does and then some. 1412 (when (or (not (invalid-wrapper-p owrapper)) 1413 ;; KLUDGE: despite the observations above, this remains 1414 ;; a violation of locality or what might be considered 1415 ;; good style. There has to be a better way! -- CSR, 1416 ;; 2002-10-29 1417 (eq (layout-invalid owrapper) t)) 1418 (let ((nwrapper (make-wrapper (layout-length owrapper) 1419 class))) 1420 (setf (layout-slot-list nwrapper) (layout-slot-list owrapper)) 1421 (setf (layout-slot-table nwrapper) (layout-slot-table owrapper)) 1422 (%update-lisp-class-layout class nwrapper) 1423 (setf (slot-value class 'wrapper) nwrapper) 1424 ;; Use :OBSOLETE instead of :FLUSH if any superclass has 1425 ;; been obsoleted. 1426 (if (find-if (lambda (x) 1427 (and (consp x) (eq :obsolete (car x)))) 1428 (layout-inherits owrapper) 1429 :key #'layout-invalid) 1430 (%invalidate-wrapper owrapper :obsolete nwrapper) 1431 (%invalidate-wrapper owrapper :flush nwrapper)))))) 1432 nil) 1433 1434;;; MAKE-INSTANCES-OBSOLETE can be called by user code. It will cause 1435;;; the next access to the instance (as defined in 88-002R) to trap 1436;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism. 1437(defmethod make-instances-obsolete ((class std-class)) 1438 (with-world-lock () 1439 (let* ((owrapper (class-wrapper class)) 1440 (nwrapper (make-wrapper (layout-length owrapper) 1441 class))) 1442 (unless (class-finalized-p class) 1443 (if (class-has-a-forward-referenced-superclass-p class) 1444 (return-from make-instances-obsolete class) 1445 (%update-cpl class (compute-class-precedence-list class)))) 1446 (setf (layout-slot-list nwrapper) (layout-slot-list owrapper)) 1447 (setf (layout-slot-table nwrapper) (layout-slot-table owrapper)) 1448 (%update-lisp-class-layout class nwrapper) 1449 (setf (slot-value class 'wrapper) nwrapper) 1450 (%invalidate-wrapper owrapper :obsolete nwrapper) 1451 class))) 1452 1453(defmethod make-instances-obsolete ((class symbol)) 1454 (make-instances-obsolete (find-class class)) 1455 ;; ANSI wants the class name when called with a symbol. 1456 class) 1457 1458;;; OBSOLETE-INSTANCE-TRAP is the internal trap that is called when we 1459;;; see an obsolete instance. The times when it is called are: 1460;;; - when the instance is involved in method lookup 1461;;; - when attempting to access a slot of an instance 1462;;; 1463;;; It is not called by class-of, wrapper-of, or any of the low-level 1464;;; instance access macros. 1465;;; 1466;;; Of course these times when it is called are an internal 1467;;; implementation detail of PCL and are not part of the documented 1468;;; description of when the obsolete instance update happens. The 1469;;; documented description is as it appears in 88-002R. 1470;;; 1471;;; This has to return the new wrapper, so it counts on all the 1472;;; methods on obsolete-instance-trap-internal to return the new 1473;;; wrapper. It also does a little internal error checking to make 1474;;; sure that the traps are only happening when they should, and that 1475;;; the trap methods are computing appropriate new wrappers. 1476 1477;;; OBSOLETE-INSTANCE-TRAP might be called on structure instances 1478;;; after a structure is redefined. In most cases, 1479;;; OBSOLETE-INSTANCE-TRAP will not be able to fix the old instance, 1480;;; so it must signal an error. The hard part of this is that the 1481;;; error system and debugger might cause OBSOLETE-INSTANCE-TRAP to be 1482;;; called again, so in that case, we have to return some reasonable 1483;;; wrapper, instead. 1484 1485(defun %ensure-slot-value-type (context slot-name slot-type value 1486 old-class new-class) 1487 (do () ((typep value slot-type)) 1488 (restart-case 1489 (bad-type value slot-type 1490 "~@<Error during ~A. Current value in slot ~ 1491 ~/sb-impl::print-symbol-with-prefix/ of an instance ~ 1492 of ~S is ~S, which does not match the new slot type ~ 1493 ~S in class ~S.~:@>" 1494 context slot-name old-class value slot-type new-class) 1495 (use-value (new-value) 1496 :interactive read-evaluated-form 1497 :report (lambda (stream) 1498 (format stream "~@<Specify a new value to by used ~ 1499 for slot ~ 1500 ~/sb-impl::print-symbol-with-prefix/ ~ 1501 instead of ~S.~@:>" 1502 slot-name value)) 1503 (setf value new-value)))) 1504 value) 1505 1506(defun %set-slot-value-checking-type (context slots slot value 1507 safe old-class new-class) 1508 (setf (clos-slots-ref slots (slot-definition-location slot)) 1509 (if (and safe (neq value +slot-unbound+)) 1510 (let ((name (slot-definition-name slot)) 1511 (type (slot-definition-type slot))) 1512 (%ensure-slot-value-type context name type value 1513 old-class new-class)) 1514 value))) 1515 1516(defvar *in-obsolete-instance-trap* nil) 1517(defvar *the-wrapper-of-structure-object* 1518 (class-wrapper (find-class 'structure-object))) 1519 1520(define-condition obsolete-structure (error) 1521 ((datum :reader obsolete-structure-datum :initarg :datum)) 1522 (:report 1523 (lambda (condition stream) 1524 ;; Don't try to print the structure, since it probably won't work. 1525 (format stream 1526 "~@<obsolete structure error for a structure of type ~2I~_~S~:>" 1527 (type-of (obsolete-structure-datum condition)))))) 1528 1529(defun %obsolete-instance-trap (owrapper nwrapper instance) 1530 (cond 1531 ((layout-for-std-class-p owrapper) 1532 (binding* ((class (wrapper-class* nwrapper)) 1533 (copy (allocate-instance class)) ;??? allocate-instance ??? 1534 (oslots (get-slots instance)) 1535 (nslots (get-slots copy)) 1536 (added ()) 1537 (discarded ()) 1538 (plist ()) 1539 (safe (safe-p class)) 1540 ((new-instance-slots nil new-custom-slots) 1541 (classify-slotds (layout-slot-list nwrapper))) 1542 ((old-instance-slots old-class-slots old-custom-slots) 1543 (classify-slotds (layout-slot-list owrapper))) 1544 (layout (mapcar (lambda (slotd) 1545 ;; Get the names only once. 1546 (cons (slot-definition-name slotd) slotd)) 1547 new-instance-slots))) 1548 ;; local --> local transfer value, check type 1549 ;; local --> shared discard value, discard slot 1550 ;; local --> -- discard slot 1551 ;; local --> custom XXX 1552 1553 ;; shared --> local transfer value, check type 1554 ;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS) 1555 ;; shared --> -- discard value 1556 ;; shared --> custom XXX 1557 1558 ;; -- --> local add slot 1559 ;; -- --> shared -- 1560 ;; -- --> custom XXX 1561 (flet ((set-value (value cell) 1562 (%set-slot-value-checking-type 1563 "updating obsolete instance" 1564 nslots (cdr cell) value safe class class) 1565 ;; Prune from the list now that it's been dealt with. 1566 (setf layout (remove cell layout)))) 1567 1568 ;; Go through all the old local slots. 1569 (dolist (old old-instance-slots) 1570 (let* ((name (slot-definition-name old)) 1571 (value (clos-slots-ref oslots (slot-definition-location old)))) 1572 (unless (eq value +slot-unbound+) 1573 (let ((new (assq name layout))) 1574 (cond (new 1575 (set-value value new)) 1576 (t 1577 (push name discarded) 1578 (setf (getf plist name) value))))))) 1579 1580 ;; Go through all the old shared slots. 1581 (dolist (old old-class-slots) 1582 (binding* ((cell (slot-definition-location old)) 1583 (name (car cell)) 1584 (new (assq name layout) :exit-if-null)) 1585 (set-value (cdr cell) new))) 1586 1587 ;; Go through all custom slots to find added ones. CLHS 1588 ;; doesn't specify what to do about them, and neither does 1589 ;; AMOP. We do want them to get initialized, though, so we 1590 ;; list them in ADDED for the benefit of SHARED-INITIALIZE. 1591 (dolist (new new-custom-slots) 1592 (let* ((name (slot-definition-name new)) 1593 (old (find name old-custom-slots 1594 :key #'slot-definition-name))) 1595 (unless old 1596 (push name added)))) 1597 1598 ;; Go through all the remaining new local slots to compute 1599 ;; the added slots. 1600 (dolist (cell layout) 1601 (push (car cell) added))) 1602 1603 (%swap-wrappers-and-slots instance copy) 1604 1605 (update-instance-for-redefined-class 1606 instance added discarded plist) 1607 1608 nwrapper)) 1609 (*in-obsolete-instance-trap* 1610 *the-wrapper-of-structure-object*) 1611 (t 1612 (let ((*in-obsolete-instance-trap* t)) 1613 (error 'obsolete-structure :datum instance))))) 1614 1615 1616(defun %change-class (instance new-class initargs) 1617 (declare (notinline allocate-instance)) 1618 (binding* ((old-class (class-of instance)) 1619 (copy (allocate-instance new-class)) 1620 (new-wrapper (get-wrapper copy)) 1621 (old-wrapper (class-wrapper old-class)) 1622 (old-slots (get-slots instance)) 1623 (new-slots (get-slots copy)) 1624 (safe (safe-p new-class)) 1625 (new-wrapper-slots (layout-slot-list new-wrapper)) 1626 (old-wrapper-slots (layout-slot-list old-wrapper))) 1627 (labels ((find-instance-slot (name slots) 1628 (loop for slot in slots 1629 when (and (eq (slot-definition-allocation slot) :instance) 1630 (eq (slot-definition-name slot) name)) 1631 return slot)) 1632 (initarg-for-slot-p (slot) 1633 (dolist (slot-initarg (slot-definition-initargs slot)) 1634 ;; Abuse +slot-unbound+ 1635 (unless (eq +slot-unbound+ 1636 (getf initargs slot-initarg +slot-unbound+)) 1637 (return t)))) 1638 (set-value (value slotd) 1639 (%set-slot-value-checking-type 1640 'change-class new-slots slotd value safe 1641 old-class new-class))) 1642 1643 ;; "The values of local slots specified by both the class CTO 1644 ;; and CFROM are retained. If such a local slot was unbound, it 1645 ;; remains unbound." 1646 (dolist (new new-wrapper-slots) 1647 (when (and (not (initarg-for-slot-p new)) 1648 (eq (slot-definition-allocation new) :instance)) 1649 (binding* ((old (find-instance-slot (slot-definition-name new) old-wrapper-slots) 1650 :exit-if-null) 1651 (value (clos-slots-ref old-slots (slot-definition-location old)))) 1652 (set-value value new)))) 1653 1654 ;; "The values of slots specified as shared in the class CFROM and 1655 ;; as local in the class CTO are retained." 1656 (dolist (old old-wrapper-slots) 1657 (when (eq (slot-definition-allocation old) :class) 1658 (binding* ((slot-and-val (slot-definition-location old)) 1659 (new (find-instance-slot (car slot-and-val) new-wrapper-slots) 1660 :exit-if-null)) 1661 (set-value (cdr slot-and-val) new))))) 1662 1663 ;; Make the copy point to the old instance's storage, and make the 1664 ;; old instance point to the new storage. 1665 (%swap-wrappers-and-slots instance copy) 1666 1667 (apply #'update-instance-for-different-class copy instance initargs) 1668 1669 instance)) 1670 1671(defun check-new-class-not-metaobject (new-class) 1672 (dolist (class (class-precedence-list 1673 (ensure-class-finalized new-class))) 1674 (macrolet 1675 ((check-metaobject (class-name) 1676 `(when (eq class (find-class ',class-name)) 1677 (change-class-to-metaobject-violation 1678 ',class-name nil '((:amop :initialization ,class-name)))))) 1679 (check-metaobject class) 1680 (check-metaobject generic-function) 1681 (check-metaobject method) 1682 (check-metaobject slot-definition)))) 1683 1684(defmethod change-class ((instance standard-object) (new-class standard-class) 1685 &rest initargs) 1686 (with-world-lock () 1687 (check-new-class-not-metaobject new-class) 1688 (%change-class instance new-class initargs))) 1689 1690(defmethod change-class ((instance forward-referenced-class) 1691 (new-class standard-class) &rest initargs) 1692 (with-world-lock () 1693 (dolist (class (class-precedence-list 1694 (ensure-class-finalized new-class)) 1695 (change-class-to-metaobject-violation 1696 '(not class) 'forward-referenced-class 1697 '((:amop :generic-function ensure-class-using-class) 1698 (:amop :initialization class)))) 1699 (when (eq class (find-class 'class)) 1700 (return nil))) 1701 (%change-class instance new-class initargs))) 1702 1703(defmethod change-class ((instance t) 1704 (new-class forward-referenced-class) &rest initargs) 1705 (declare (ignore initargs)) 1706 (change-class-to-metaobject-violation 1707 'forward-referenced-class nil 1708 '((:amop :generic-function ensure-class-using-class) 1709 (:amop :initialization class)))) 1710 1711(defmethod change-class ((instance funcallable-standard-object) 1712 (new-class funcallable-standard-class) 1713 &rest initargs) 1714 (with-world-lock () 1715 (check-new-class-not-metaobject new-class) 1716 (%change-class instance new-class initargs))) 1717 1718(defmethod change-class ((instance standard-object) 1719 (new-class funcallable-standard-class) 1720 &rest initargs) 1721 (declare (ignore initargs)) 1722 (error "You can't change the class of ~S to ~S~@ 1723 because it isn't already an instance with metaclass ~S." 1724 instance new-class 'standard-class)) 1725 1726(defmethod change-class ((instance funcallable-standard-object) 1727 (new-class standard-class) 1728 &rest initargs) 1729 (declare (ignore initargs)) 1730 (error "You can't change the class of ~S to ~S~@ 1731 because it isn't already an instance with metaclass ~S." 1732 instance new-class 'funcallable-standard-class)) 1733 1734(defmethod change-class ((instance t) (new-class-name symbol) &rest initargs) 1735 (apply #'change-class instance (find-class new-class-name) initargs)) 1736 1737;;;; The metaclasses SYSTEM-CLASS and BUILT-IN-CLASS 1738;;;; 1739;;;; These metaclasses are something of a weird creature. By this 1740;;;; point, all instances which will exist have been created, and no 1741;;;; instance is ever created by calling MAKE-INSTANCE. (The 1742;;;; distinction between the metaclasses is that we allow subclassing 1743;;;; of SYSTEM-CLASS, such as through STREAM and SEQUENCE protocols, 1744;;;; but not of BUILT-IN-CLASS.) 1745;;;; 1746;;;; AMOP mandates some behaviour of the implementation with respect 1747;;;; to BUILT-IN-CLASSes, and we implement that through methods on 1748;;;; SYSTEM-CLASS here. 1749 1750(macrolet ((def (name args control) 1751 `(defmethod ,name ,args 1752 (declare (ignore initargs)) 1753 (error 'metaobject-initialization-violation 1754 :format-control ,(coerce (format nil "~@<~A~@:>" control) 1755 'base-string) 1756 :format-arguments (list (class-name class)) 1757 :references (list '(:amop :initialization "Class")))))) 1758 (def initialize-instance ((class system-class) &rest initargs) 1759 "Cannot initialize an instance of ~S.") 1760 (def reinitialize-instance ((class system-class) &rest initargs) 1761 "Cannot reinitialize an instance of ~S.")) 1762 1763(macrolet ((def (name) `(defmethod ,name ((class system-class)) nil))) 1764 (def class-direct-slots) 1765 (def class-slots) 1766 (def class-direct-default-initargs) 1767 (def class-default-initargs)) 1768 1769(defmethod validate-superclass ((c class) (s system-class)) 1770 t) 1771(defmethod validate-superclass ((c class) (s built-in-class)) 1772 nil) 1773 1774;;; Some necessary methods for FORWARD-REFERENCED-CLASS 1775(defmethod class-direct-slots ((class forward-referenced-class)) ()) 1776(defmethod class-direct-default-initargs ((class forward-referenced-class)) ()) 1777(macrolet ((def (method) 1778 `(defmethod ,method ((class forward-referenced-class)) 1779 (error "~@<~I~S was called on a forward referenced class:~2I~_~S~:>" 1780 ',method class)))) 1781 (def class-default-initargs) 1782 (def class-precedence-list) 1783 (def class-slots)) 1784 1785(defmethod validate-superclass ((c slot-class) (f forward-referenced-class)) 1786 t) 1787 1788(defmethod add-dependent ((metaobject dependent-update-mixin) dependent) 1789 (pushnew dependent (plist-value metaobject 'dependents) :test #'eq)) 1790 1791(defmethod remove-dependent ((metaobject dependent-update-mixin) dependent) 1792 (setf (plist-value metaobject 'dependents) 1793 (delete dependent (plist-value metaobject 'dependents)))) 1794 1795(defmethod map-dependents ((metaobject dependent-update-mixin) function) 1796 (dolist (dependent (plist-value metaobject 'dependents)) 1797 (funcall function dependent))) 1798