362 |
(supplied-supers (getf initargs :direct-superclasses unsupplied)) |
(supplied-supers (getf initargs :direct-superclasses unsupplied)) |
363 |
(supplied-slots (getf initargs :direct-slots unsupplied)) |
(supplied-slots (getf initargs :direct-slots unsupplied)) |
364 |
(meta |
(meta |
365 |
(cond ((neq supplied-meta unsupplied) |
(cond ((neq supplied-meta unsupplied) |
366 |
(find-class supplied-meta)) |
(find-class supplied-meta)) |
367 |
((or (null class) |
((or (null class) |
368 |
(forward-referenced-class-p class)) |
(forward-referenced-class-p class)) |
369 |
*the-class-standard-class*) |
*the-class-standard-class*) |
370 |
(t |
(t |
371 |
(class-of class))))) |
(class-of class))))) |
372 |
(flet ((fix-super (s) |
(flet ((fix-super (s) |
373 |
(cond ((classp s) s) |
(cond ((classp s) s) |
374 |
((not (legal-class-name-p s)) |
((not (legal-class-name-p s)) |
375 |
(error "~S is not a class or a legal class name." s)) |
(error "~S is not a class or a legal class name." s)) |
376 |
(t |
(t |
377 |
(or (find-class s nil) |
(or (find-class s nil) |
378 |
(setf (find-class s) |
(setf (find-class s) |
379 |
(make-instance 'forward-referenced-class |
(make-instance 'forward-referenced-class |
380 |
:name s))))))) |
:name s))))))) |
381 |
(loop (unless (remf initargs :metaclass) (return))) |
;; |
382 |
(loop (unless (remf initargs :direct-superclasses) (return))) |
;; CLHS: signal PROGRAM-ERROR, if |
383 |
(loop (unless (remf initargs :direct-slots) (return))) |
;; (a) there are any duplicate slot names |
384 |
(values meta |
;; (b) any of the slot options :ALLOCATION, :INITFORM, :TYPE, or |
385 |
(list* :direct-superclasses |
;; :DOCUMENTATION appears more than one in a single slot description. |
386 |
(and (neq supplied-supers unsupplied) |
(loop for (slot . more) on (getf initargs :direct-slots) |
387 |
(mapcar #'fix-super supplied-supers)) |
for slot-name = (getf slot :name) |
388 |
:direct-slots |
if (some (lambda (s) (eq slot-name (getf s :name))) more) do |
389 |
(and (neq supplied-slots unsupplied) supplied-slots) |
(specific-error :invalid-form |
390 |
initargs))))) |
"More than one direct slot with name ~S." |
391 |
|
slot-name) |
392 |
|
else do |
393 |
|
(loop for (option value . more) on slot by #'cddr |
394 |
|
when (and (member option '(:allocation :type :initform |
395 |
|
:documentation)) |
396 |
|
(not (eq unsupplied |
397 |
|
(getf more option unsupplied)))) do |
398 |
|
(specific-error :invalid-form |
399 |
|
"Duplicate slot option ~S for slot ~S." |
400 |
|
option slot-name))) |
401 |
|
;; |
402 |
|
;; CLHS: signal PROGRAM-ERROR, if an initialization argument name |
403 |
|
;; appears more than once in :DEFAULT-INITARGS class option. |
404 |
|
(loop for (initarg . more) on (getf initargs :direct-default-initargs) |
405 |
|
for name = (car initarg) |
406 |
|
when (some (lambda (a) (eq (car a) name)) more) do |
407 |
|
(specific-error :invalid-form |
408 |
|
"Duplicate initialization argument ~ |
409 |
|
name ~S in :default-initargs of class ~A." |
410 |
|
name class)) |
411 |
|
;; |
412 |
|
(loop (unless (remf initargs :metaclass) (return))) |
413 |
|
(loop (unless (remf initargs :direct-superclasses) (return))) |
414 |
|
(loop (unless (remf initargs :direct-slots) (return))) |
415 |
|
(values meta |
416 |
|
(list* :direct-superclasses |
417 |
|
(and (neq supplied-supers unsupplied) |
418 |
|
(mapcar #'fix-super supplied-supers)) |
419 |
|
:direct-slots |
420 |
|
(and (neq supplied-slots unsupplied) supplied-slots) |
421 |
|
initargs))))) |
422 |
|
|
423 |
|
|
424 |
;;; |
;;; |
1235 |
#+new-kcl-wrapper |
#+new-kcl-wrapper |
1236 |
(copy-structure-header ,instance))) |
(copy-structure-header ,instance))) |
1237 |
|
|
1238 |
(defun change-class-internal (instance new-class) |
(defun change-class-internal (instance new-class initargs) |
1239 |
(let* ((old-class (class-of instance)) |
(let* ((old-class (class-of instance)) |
1240 |
(copy (allocate-instance new-class)) |
(copy (allocate-instance new-class)) |
1241 |
(new-wrapper (get-wrapper copy)) |
(new-wrapper (get-wrapper copy)) |
1251 |
;; Cfrom are retained. If such a local slot was unbound, it remains |
;; Cfrom are retained. If such a local slot was unbound, it remains |
1252 |
;; unbound." |
;; unbound." |
1253 |
;; |
;; |
1254 |
(iterate ((new-slot (list-elements new-layout)) |
(loop for new-slot in new-layout and new-position from 0 |
1255 |
(new-position (interval :from 0))) |
for old-position = (posq new-slot old-layout) |
1256 |
(let* ((new-position new-position) |
when old-position do |
1257 |
(old-position (posq new-slot old-layout))) |
(setf (instance-ref new-slots new-position) |
1258 |
(declare (fixnum new-position)) |
(instance-ref old-slots old-position))) |
|
(when old-position |
|
|
(setf (instance-ref new-slots new-position) |
|
|
(instance-ref old-slots old-position))))) |
|
1259 |
|
|
1260 |
;; |
;; |
1261 |
;; "The values of slots specified as shared in the class Cfrom and |
;; "The values of slots specified as shared in the class Cfrom and |
1262 |
;; as local in the class Cto are retained." |
;; as local in the class Cto are retained." |
1263 |
;; |
;; |
1264 |
(iterate ((slot-and-val (list-elements old-class-slots))) |
(loop for (name . val) in old-class-slots |
1265 |
(let ((position (posq (car slot-and-val) new-layout))) |
for new-position = (posq name new-layout) |
1266 |
(when position |
when new-position do |
1267 |
(setf (instance-ref new-slots position) (cdr slot-and-val))))) |
(setf (instance-ref new-slots new-position) val)) |
1268 |
|
|
1269 |
;; Make the copy point to the old instance's storage, and make the |
;; Make the copy point to the old instance's storage, and make the |
1270 |
;; old instance point to the new storage. |
;; old instance point to the new storage. |
1271 |
(swap-wrappers-and-slots instance copy) |
(swap-wrappers-and-slots instance copy) |
1272 |
|
|
1273 |
(update-instance-for-different-class copy instance) |
(apply #'update-instance-for-different-class copy instance initargs) |
1274 |
instance)) |
instance)) |
1275 |
|
|
1276 |
(defmethod change-class ((instance standard-object) |
(defmethod change-class ((instance standard-object) |
1277 |
(new-class standard-class)) |
(new-class standard-class) |
1278 |
(unless (std-instance-p instance) |
&rest initargs) |
1279 |
(error "Can't change the class of ~S to ~S~@ |
(change-class-internal instance new-class initargs)) |
1280 |
because it isn't already an instance with metaclass~%~S." |
|
1281 |
instance |
;; FIXME add class funcallable-standard-object ?? |
1282 |
new-class |
;(defmethod change-class ((instance funcallable-standard-object) |
1283 |
'standard-class)) |
; (new-class funcallable-standard-class) |
1284 |
(change-class-internal instance new-class)) |
; &rest initargs) |
1285 |
|
; (change-class-internal instance new-class initargs)) |
1286 |
|
|
1287 |
(defmethod change-class ((instance standard-object) |
(defmethod change-class ((instance standard-object) |
1288 |
(new-class funcallable-standard-class)) |
(new-class funcallable-standard-class) |
1289 |
(unless (fsc-instance-p instance) |
&rest initargs) |
1290 |
(error "Can't change the class of ~S to ~S~@ |
(declare (ignore initargs)) |
1291 |
because it isn't already an instance with metaclass~%~S." |
(error "Can't change the class of ~S to ~S~@ |
1292 |
instance |
because it isn't already an instance with metaclass ~S." |
1293 |
new-class |
instance new-class 'standard-class)) |
1294 |
'funcallable-standard-class)) |
|
1295 |
(change-class-internal instance new-class)) |
;(defmethod change-class ((instance funcallable-standard-object) |
1296 |
|
; (new-class standard-class) |
1297 |
|
; &rest initargs) |
1298 |
|
; (declare (ignore initargs)) |
1299 |
|
; (error "Can't change the class of ~S to ~S~@ |
1300 |
|
; because it isn't already an instance with metaclass ~S." |
1301 |
|
; instance new-class 'funcallable-standard-class)) |
1302 |
|
|
1303 |
|
(defmethod change-class ((instance t) (new-class-name symbol) &rest initargs) |
1304 |
|
(apply #'change-class instance (find-class new-class-name) initargs)) |
1305 |
|
|
|
(defmethod change-class ((instance t) (new-class-name symbol)) |
|
|
(change-class instance (find-class new-class-name))) |
|
1306 |
|
|
1307 |
|
|
1308 |
|
|