1 ;;; *************************************************************************
2 ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
3 ;;; All rights reserved.
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.
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
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
18 ;;; 3333 Coyote Hill Rd.
19 ;;; Palo Alto, CA 94304
20 ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
22 ;;; Suggestions, comments and requests for improvements are also welcome.
23 ;;; *************************************************************************
26 ;;; Modifications for better AMOP conformance
27 ;;; Copyright (C) 2001 Espen S. Johnsen <esj@stud.cs.uit.no>
31 ;;;; Adding initargs parameter to change-class
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)))
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
49 (iterate ((new-slot (list-elements new-layout))
50 (new-position (interval :from 0)))
51 (let ((old-position (posq new-slot old-layout)))
53 (setf (instance-ref new-slots new-position)
54 (instance-ref old-slots old-position)))))
57 ;; "The values of slots specified as shared in the class Cfrom and
58 ;; as local in the class Cto are retained."
60 (iterate ((slot-and-val (list-elements old-class-slots)))
61 (let ((position (posq (car slot-and-val) new-layout)))
63 (setf (instance-ref new-slots position) (cdr slot-and-val)))))
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)
69 (apply #'update-instance-for-different-class copy instance initargs)
73 (fmakunbound 'change-class)
74 (defgeneric change-class (instance new-class &rest initargs))
76 (defmethod change-class ((instance standard-object)
77 (new-class standard-class)
79 (change-class-internal instance new-class initargs))
81 (defmethod change-class ((instance funcallable-standard-object)
82 (new-class funcallable-standard-class)
84 (change-class-internal instance new-class initargs))
86 (defmethod change-class ((instance standard-object)
87 (new-class funcallable-standard-class)
89 (declare (ignore initargs))
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))
94 (defmethod change-class ((instance funcallable-standard-object)
95 (new-class standard-class)
97 (declare (ignore initargs))
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))
102 (defmethod change-class ((instance t) (new-class symbol) &rest initargs)
103 (change-class instance (find-class new-class) initargs))
106 ;;;; Make the class finalization protocol behave as specified in AMOP
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)
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))
127 (defmethod finalize-inheritance ((class forward-referenced-class))
128 (error "~A can't be finalized" class))
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))))