9f228372 |
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 | ;;; Copyright (C) 2001 Espen S. Johnsen <esj@stud.cs.uit.no> |
28 | |
9f228372 |
29 | |
4d83a8a6 |
30 | (eval-when (:compile-toplevel :load-toplevel :execute) |
31 | (setf (ext:package-lock (find-package "PCL")) nil)) |
9f228372 |
32 | |
4d83a8a6 |
33 | (in-package "PCL") |
9f228372 |
34 | |
4d83a8a6 |
35 | (defstruct slot-info |
36 | (name nil :type symbol) |
37 | ;; |
38 | ;; Specified slot allocation.or :INSTANCE. |
39 | (allocation :instance :type symbol) |
40 | ;; |
41 | ;; Specified slot type or T. |
42 | (type t :type (or symbol list number))) |
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)))) |
9f228372 |
70 | ;; |
4d83a8a6 |
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))))) |
9f228372 |
119 | |