| 1 | ;;; ************************************************************************* |
| 2 | ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. |
| 3 | ;;; All rights reserved. |
| 4 | ;;; |
| 5 | ;;; Use and copying of this software and preparation of derivative works |
| 6 | ;;; based upon this software are permitted. Any distribution of this |
| 7 | ;;; software or derivative works must comply with all applicable United |
| 8 | ;;; States export control laws. |
| 9 | ;;; |
| 10 | ;;; This software is made available AS IS, and Xerox Corporation makes no |
| 11 | ;;; warranty about the software, its performance or its conformity to any |
| 12 | ;;; specification. |
| 13 | ;;; |
| 14 | ;;; Any person obtaining a copy of this software is requested to send their |
| 15 | ;;; name and post office or electronic mail address to: |
| 16 | ;;; CommonLoops Coordinator |
| 17 | ;;; Xerox PARC |
| 18 | ;;; 3333 Coyote Hill Rd. |
| 19 | ;;; Palo Alto, CA 94304 |
| 20 | ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa) |
| 21 | ;;; |
| 22 | ;;; Suggestions, comments and requests for improvements are also welcome. |
| 23 | ;;; ************************************************************************* |
| 24 | ;;; |
| 25 | |
| 26 | ;;; Modifications for better AMOP conformance |
| 27 | ;;; by Espen S. Johnsen <espen@users.sf.net> |
| 28 | |
| 29 | |
| 30 | (eval-when (:compile-toplevel :load-toplevel :execute) |
| 31 | (setf (ext:package-lock (find-package "PCL")) nil)) |
| 32 | |
| 33 | (in-package "PCL") |
| 34 | |
| 35 | (defstruct slot-info |
| 36 | (name nil :type symbol) |
| 37 | ;; |
| 38 | ;; Specified slot allocation.or :INSTANCE. |
| 39 | (allocation :instance :type (or (member :class :instance) t)) |
| 40 | ;; |
| 41 | ;; Specified slot type or T. |
| 42 | (type t :type (or symbol list))) |
| 43 | |
| 44 | |
| 45 | (defmethod compute-slots :around ((class standard-class)) |
| 46 | (loop with slotds = (call-next-method) and location = -1 |
| 47 | for slot in slotds do |
| 48 | (setf (slot-definition-location slot) |
| 49 | (case (slot-definition-allocation slot) |
| 50 | (:instance |
| 51 | (incf location)) |
| 52 | (:class |
| 53 | (let* ((name (slot-definition-name slot)) |
| 54 | (from-class (slot-definition-allocation-class slot)) |
| 55 | (cell (assq name (class-slot-cells from-class)))) |
| 56 | (assert (consp cell)) |
| 57 | cell)))) |
| 58 | (initialize-internal-slot-functions slot) |
| 59 | finally |
| 60 | (return slotds))) |
| 61 | |
| 62 | |
| 63 | |
| 64 | (defun update-slots (class eslotds) |
| 65 | (collect ((instance-slots) (class-slots)) |
| 66 | (dolist (eslotd eslotds) |
| 67 | (case (slot-definition-allocation eslotd) |
| 68 | (:instance (instance-slots eslotd)) |
| 69 | (:class (class-slots eslotd)))) |
| 70 | ;; |
| 71 | ;; If there is a change in the shape of the instances then the |
| 72 | ;; old class is now obsolete. |
| 73 | (let* ((nlayout (mapcar #'slot-definition-name |
| 74 | (sort (instance-slots) #'< |
| 75 | :key #'slot-definition-location))) |
| 76 | (nslots (length nlayout)) |
| 77 | (nwrapper-class-slots (compute-class-slots (class-slots))) |
| 78 | (owrapper (when (class-finalized-p class) |
| 79 | (class-wrapper class))) |
| 80 | (olayout (when owrapper |
| 81 | (wrapper-instance-slots-layout owrapper))) |
| 82 | (nwrapper |
| 83 | (cond ((null owrapper) |
| 84 | (make-wrapper nslots class)) |
| 85 | ;; |
| 86 | ;; We cannot reuse the old wrapper easily when it |
| 87 | ;; has class slot cells, even if these cells are |
| 88 | ;; EQUAL to the ones used in the new wrapper. The |
| 89 | ;; class slot cells of OWRAPPER may be referenced |
| 90 | ;; from caches, and if we don't change the wrapper, |
| 91 | ;; the caches won't notice that something has |
| 92 | ;; changed. We could do something here manually, |
| 93 | ;; but I don't think it's worth it. |
| 94 | ((and (equal nlayout olayout) |
| 95 | (null (wrapper-class-slots owrapper))) |
| 96 | owrapper) |
| 97 | (t |
| 98 | ;; |
| 99 | ;; This will initialize the new wrapper to have the same |
| 100 | ;; state as the old wrapper. We will then have to change |
| 101 | ;; that. This may seem like wasted work (it is), but the |
| 102 | ;; spec requires that we call make-instances-obsolete. |
| 103 | (make-instances-obsolete class) |
| 104 | (class-wrapper class))))) |
| 105 | |
| 106 | (with-slots (wrapper slots finalized-p) class |
| 107 | (update-lisp-class-layout class nwrapper) |
| 108 | (setf slots eslotds |
| 109 | (wrapper-instance-slots-layout nwrapper) nlayout |
| 110 | (wrapper-class-slots nwrapper) nwrapper-class-slots |
| 111 | (wrapper-no-of-instance-slots nwrapper) nslots |
| 112 | wrapper nwrapper |
| 113 | finalized-p t)) |
| 114 | |
| 115 | (unless (eq owrapper nwrapper) |
| 116 | (update-inline-access class) |
| 117 | (update-pv-table-cache-info class) |
| 118 | (maybe-update-standard-class-locations class))))) |
| 119 | |
| 120 | |
| 121 | (pushnew :non-broken-pcl *features*) |