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 (error "Can't change the class of ~S to ~S~@
90 because it isn't already an instance with metaclass ~S."
91 instance new-class 'standard-class))
93 (defmethod change-class ((instance funcallable-standard-object)
94 (new-class standard-class)
96 (error "Can't change the class of ~S to ~S~@
97 because it isn't already an instance with metaclass ~S."
98 instance new-class 'funcallable-standard-class))
100 (defmethod change-class ((instance t) (new-class symbol) &rest initargs)
101 (change-class instance (find-class new-class) initargs))
104 ;;;; Make the class finalization protocol behave as specified in AMOP
106 (defmethod ensure-class-using-class (name (class pcl-class) &rest args &key)
107 (multiple-value-bind (meta initargs)
108 (ensure-class-values class args)
109 (if (eq (class-of class) meta)
110 (apply #'reinitialize-instance class initargs)
111 (apply #'change-class class meta initargs))
112 (setf (find-class name) class)
113 (inform-type-system-about-class class name)
116 (defmethod finalize-inheritance ((class std-class))
117 (dolist (super (class-direct-superclasses class))
118 (unless (class-finalized-p super) (finalize-inheritance super)))
119 (update-cpl class (compute-class-precedence-list class))
120 (update-slots class (compute-slots class))
121 (update-gfs-of-class class)
122 (update-inits class (compute-default-initargs class))
123 (update-make-instance-function-table class))
125 (defmethod finalize-inheritance ((class forward-referenced-class))
126 (error "~A can't be finalized" class))
128 (defun update-class (class &optional finalizep)
129 (declare (ignore finalizep))
130 (unless (class-has-a-forward-referenced-superclass-p class)
131 (finalize-inheritance class)
132 (dolist (sub (class-direct-subclasses class))
133 (update-class sub))))