3f747e74 |
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 | |
29 | (in-package "PCL") |
30 | |
31 | ;;;; Adding initargs parameter to change-class |
32 | |
33 | (defun change-class-internal (instance new-class initargs) |
34 | (let* ((old-class (class-of instance)) |
35 | (copy (allocate-instance new-class)) |
36 | (new-wrapper (get-wrapper copy)) |
37 | (old-wrapper (class-wrapper old-class)) |
38 | (old-layout (wrapper-instance-slots-layout old-wrapper)) |
39 | (new-layout (wrapper-instance-slots-layout new-wrapper)) |
40 | (old-slots (get-slots instance)) |
41 | (new-slots (get-slots copy)) |
42 | (old-class-slots (wrapper-class-slots old-wrapper))) |
43 | |
44 | ;; |
45 | ;; "The values of local slots specified by both the class Cto and |
46 | ;; Cfrom are retained. If such a local slot was unbound, it remains |
47 | ;; unbound." |
48 | ;; |
49 | (iterate ((new-slot (list-elements new-layout)) |
50 | (new-position (interval :from 0))) |
51 | (let ((old-position (posq new-slot old-layout))) |
52 | (when old-position |
53 | (setf (instance-ref new-slots new-position) |
54 | (instance-ref old-slots old-position))))) |
55 | |
56 | ;; |
57 | ;; "The values of slots specified as shared in the class Cfrom and |
58 | ;; as local in the class Cto are retained." |
59 | ;; |
60 | (iterate ((slot-and-val (list-elements old-class-slots))) |
61 | (let ((position (posq (car slot-and-val) new-layout))) |
62 | (when position |
63 | (setf (instance-ref new-slots position) (cdr slot-and-val))))) |
64 | |
65 | ;; Make the copy point to the old instance's storage, and make the |
66 | ;; old instance point to the new storage. |
67 | (swap-wrappers-and-slots instance copy) |
68 | |
69 | (apply #'update-instance-for-different-class copy instance initargs) |
70 | instance)) |
71 | |
72 | |
73 | (fmakunbound 'change-class) |
74 | (defgeneric change-class (instance new-class &rest initargs)) |
75 | |
76 | (defmethod change-class ((instance standard-object) |
77 | (new-class standard-class) |
78 | &rest initargs) |
79 | (change-class-internal instance new-class initargs)) |
80 | |
81 | (defmethod change-class ((instance funcallable-standard-object) |
82 | (new-class funcallable-standard-class) |
83 | &rest initargs) |
84 | (change-class-internal instance new-class initargs)) |
85 | |
86 | (defmethod change-class ((instance standard-object) |
87 | (new-class funcallable-standard-class) |
88 | &rest initargs) |
30279859 |
89 | (declare (ignore initargs)) |
3f747e74 |
90 | (error "Can't change the class of ~S to ~S~@ |
91 | because it isn't already an instance with metaclass ~S." |
92 | instance new-class 'standard-class)) |
93 | |
94 | (defmethod change-class ((instance funcallable-standard-object) |
95 | (new-class standard-class) |
96 | &rest initargs) |
30279859 |
97 | (declare (ignore initargs)) |
3f747e74 |
98 | (error "Can't change the class of ~S to ~S~@ |
99 | because it isn't already an instance with metaclass ~S." |
100 | instance new-class 'funcallable-standard-class)) |
101 | |
102 | (defmethod change-class ((instance t) (new-class symbol) &rest initargs) |
103 | (change-class instance (find-class new-class) initargs)) |
104 | |
105 | |
106 | ;;;; Make the class finalization protocol behave as specified in AMOP |
107 | |
108 | (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key) |
109 | (multiple-value-bind (meta initargs) |
110 | (ensure-class-values class args) |
111 | (if (eq (class-of class) meta) |
112 | (apply #'reinitialize-instance class initargs) |
113 | (apply #'change-class class meta initargs)) |
114 | (setf (find-class name) class) |
115 | (inform-type-system-about-class class name) |
116 | class)) |
117 | |
118 | (defmethod finalize-inheritance ((class std-class)) |
119 | (dolist (super (class-direct-superclasses class)) |
120 | (unless (class-finalized-p super) (finalize-inheritance super))) |
121 | (update-cpl class (compute-class-precedence-list class)) |
122 | (update-slots class (compute-slots class)) |
123 | (update-gfs-of-class class) |
124 | (update-inits class (compute-default-initargs class)) |
125 | (update-make-instance-function-table class)) |
126 | |
127 | (defmethod finalize-inheritance ((class forward-referenced-class)) |
128 | (error "~A can't be finalized" class)) |
129 | |
130 | (defun update-class (class &optional finalizep) |
131 | (declare (ignore finalizep)) |
132 | (unless (class-has-a-forward-referenced-superclass-p class) |
133 | (finalize-inheritance class) |
134 | (dolist (sub (class-direct-subclasses class)) |
135 | (update-class sub)))) |
136 | |