| 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) |
| 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)) |
| 92 | |
| 93 | (defmethod change-class ((instance funcallable-standard-object) |
| 94 | (new-class standard-class) |
| 95 | &rest initargs) |
| 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)) |
| 99 | |
| 100 | (defmethod change-class ((instance t) (new-class symbol) &rest initargs) |
| 101 | (change-class instance (find-class new-class) initargs)) |
| 102 | |
| 103 | |
| 104 | ;;;; Make the class finalization protocol behave as specified in AMOP |
| 105 | |
| 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) |
| 114 | class)) |
| 115 | |
| 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)) |
| 124 | |
| 125 | (defmethod finalize-inheritance ((class forward-referenced-class)) |
| 126 | (error "~A can't be finalized" class)) |
| 127 | |
| 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)))) |
| 134 | |