315 |
z |
z |
316 |
x y z))) |
x y z))) |
317 |
|
|
318 |
|
;;; Same as class-redefinition.1, but reverse the order in which |
319 |
|
;;; the classes are redefined. |
320 |
|
(deftest class-redefinition.3 |
321 |
|
(let* |
322 |
|
((cobj1 (eval '(defclass class-redef-03a () |
323 |
|
((a :allocation :class :initform 'x))))) |
324 |
|
(cobj2 (eval '(defclass class-redef-03b (class-redef-03a) |
325 |
|
((a :allocation :instance))))) |
326 |
|
(cobj4 (eval '(defclass class-redef-03b (class-redef-03a) |
327 |
|
((a :allocation :instance))))) |
328 |
|
(cobj3 (eval '(defclass class-redef-03a () |
329 |
|
((a :allocation :class :initform 'x)))))) |
330 |
|
(values |
331 |
|
(eqt cobj1 cobj3) |
332 |
|
(eqt cobj2 cobj4) |
333 |
|
(class-name cobj1) |
334 |
|
(class-name cobj2) |
335 |
|
(slot-value (make-instance 'class-redef-03a) 'a) |
336 |
|
(slot-value (make-instance 'class-redef-03b) 'a))) |
337 |
|
t t |
338 |
|
class-redef-03a |
339 |
|
class-redef-03b |
340 |
|
x x) |
341 |
|
|
342 |
;;; Initforms are inherited even if :allocation changes |
;;; Initforms are inherited even if :allocation changes |
343 |
|
|
344 |
(defclass class-0211a () |
(defclass class-0211a () |
353 |
(slot-value (make-instance 'class-0211b) 'a)) |
(slot-value (make-instance 'class-0211b) 'a)) |
354 |
x x) |
x x) |
355 |
|
|
356 |
|
;;; |
357 |
|
|
358 |
|
;;; Inheritance of :initargs |
359 |
|
|
360 |
|
(defclass class-0212a () |
361 |
|
((a :initarg :a1))) |
362 |
|
|
363 |
|
(defclass class-0212b (class-0212a) |
364 |
|
((a :initarg :a2) |
365 |
|
(b :initarg :b))) |
366 |
|
|
367 |
|
(deftest class-0212.1 |
368 |
|
(let ((c (make-instance 'class-0212a :a1 'x))) |
369 |
|
(values |
370 |
|
(typep* c 'class-0212a) |
371 |
|
(typep* c 'class-0212b) |
372 |
|
(slot-value c 'a) |
373 |
|
(slot-exists-p c 'b))) |
374 |
|
t nil x nil) |
375 |
|
|
376 |
|
(deftest class-0212.2 |
377 |
|
(let ((c (make-instance 'class-0212b :a1 'x))) |
378 |
|
(values |
379 |
|
(typep* c 'class-0212a) |
380 |
|
(typep* c 'class-0212b) |
381 |
|
(slot-value c 'a) |
382 |
|
(slot-boundp* c 'b))) |
383 |
|
t t x nil) |
384 |
|
|
385 |
|
(deftest class-0212.3 |
386 |
|
(let ((c (make-instance 'class-0212b :a2 'x :b 'y))) |
387 |
|
(values |
388 |
|
(typep* c 'class-0212a) |
389 |
|
(typep* c 'class-0212b) |
390 |
|
(slot-value c 'a) |
391 |
|
(slot-value c 'b))) |
392 |
|
t t x y) |
393 |
|
|
394 |
|
(deftest class-0212.4 |
395 |
|
(let ((c (make-instance 'class-0212b :a1 'z :a2 'x :b 'y))) |
396 |
|
(values |
397 |
|
(typep* c 'class-0212a) |
398 |
|
(typep* c 'class-0212b) |
399 |
|
(slot-value c 'a) |
400 |
|
(slot-value c 'b))) |
401 |
|
t t z y) |
402 |
|
|
403 |
|
(deftest class-0212.5 |
404 |
|
(let ((c (make-instance 'class-0212b :a2 'x :b 'y :a1 'z))) |
405 |
|
(values |
406 |
|
(typep* c 'class-0212a) |
407 |
|
(typep* c 'class-0212b) |
408 |
|
(slot-value c 'a) |
409 |
|
(slot-value c 'b))) |
410 |
|
t t x y) |
411 |
|
|
412 |
|
;;; |
413 |
|
|
414 |
|
(defclass class-0213a () |
415 |
|
((a :initarg :a1))) |
416 |
|
|
417 |
|
(defclass class-0213b (class-0213a) |
418 |
|
(b)) |
419 |
|
|
420 |
|
(deftest class-0213.1 |
421 |
|
(let ((c (make-instance 'class-0213a :a1 'x))) |
422 |
|
(values |
423 |
|
(typep* c 'class-0213a) |
424 |
|
(typep* c 'class-0213b) |
425 |
|
(slot-value c 'a) |
426 |
|
(slot-exists-p c 'b))) |
427 |
|
t nil x nil) |
428 |
|
|
429 |
|
(deftest class-0213.2 |
430 |
|
(let ((c (make-instance 'class-0213b :a1 'x))) |
431 |
|
(values |
432 |
|
(typep* c 'class-0213a) |
433 |
|
(typep* c 'class-0213b) |
434 |
|
(slot-value c 'a) |
435 |
|
(slot-boundp* c 'b))) |
436 |
|
t t x nil) |
437 |
|
|
438 |
|
;;; |
439 |
|
|
440 |
|
(defclass class-0214a () |
441 |
|
((a :initarg :a1 :allocation :class))) |
442 |
|
|
443 |
|
(defclass class-0214b (class-0214a) |
444 |
|
(b)) |
445 |
|
|
446 |
|
(deftest class-0214.1 |
447 |
|
(let ((c (make-instance 'class-0214a :a1 'x))) |
448 |
|
(values |
449 |
|
(typep* c 'class-0214a) |
450 |
|
(typep* c 'class-0214b) |
451 |
|
(slot-value c 'a) |
452 |
|
(slot-exists-p c 'b))) |
453 |
|
t nil x nil) |
454 |
|
|
455 |
|
(deftest class-0214.2 |
456 |
|
(let ((c (make-instance 'class-0214b :a1 'y))) |
457 |
|
(values |
458 |
|
(typep* c 'class-0214a) |
459 |
|
(typep* c 'class-0214b) |
460 |
|
(slot-value c 'a) |
461 |
|
(slot-boundp* c 'b))) |
462 |
|
t t y nil) |
463 |
|
|
464 |
|
;;; |
465 |
|
|
466 |
|
(defclass class-0215a () |
467 |
|
((a :initarg :a1 :allocation :instance))) |
468 |
|
|
469 |
|
(defclass class-0215b (class-0215a) |
470 |
|
((a :allocation :class))) |
471 |
|
|
472 |
|
(deftest class-0215.1 |
473 |
|
(let ((c (make-instance 'class-0215a :a1 'x))) |
474 |
|
(values |
475 |
|
(typep* c 'class-0215a) |
476 |
|
(typep* c 'class-0215b) |
477 |
|
(slot-value c 'a))) |
478 |
|
t nil x) |
479 |
|
|
480 |
|
(deftest class-0215.2 |
481 |
|
(let ((c (make-instance 'class-0215b :a1 'y))) |
482 |
|
(values |
483 |
|
(typep* c 'class-0215a) |
484 |
|
(typep* c 'class-0215b) |
485 |
|
(slot-value c 'a))) |
486 |
|
t t y) |
487 |
|
|
488 |
|
|
489 |
|
;;; Tests of defaulted initargs |
490 |
|
|
491 |
|
(defclass class-0216a () |
492 |
|
((a :initarg :a1) |
493 |
|
(b :initarg :b1))) |
494 |
|
|
495 |
|
(defclass class-0216b (class-0216a) |
496 |
|
() |
497 |
|
(:default-initargs :a1 'x)) |
498 |
|
|
499 |
|
(deftest class-0216.1 |
500 |
|
(let ((c (make-instance 'class-0216a))) |
501 |
|
(values |
502 |
|
(typep* c 'class-0216a) |
503 |
|
(typep* c 'class-0216b) |
504 |
|
(slot-boundp c 'a) |
505 |
|
(slot-boundp c 'b))) |
506 |
|
t nil nil nil) |
507 |
|
|
508 |
|
(deftest class-0216.2 |
509 |
|
(let ((c (make-instance 'class-0216b))) |
510 |
|
(values |
511 |
|
(typep* c 'class-0216a) |
512 |
|
(typep* c 'class-0216b) |
513 |
|
(slot-value c 'a) |
514 |
|
(slot-boundp c 'b))) |
515 |
|
t t x nil) |
516 |
|
|
517 |
|
;;; |
518 |
|
|
519 |
|
(defclass class-0217a () |
520 |
|
((a :initarg :a1) |
521 |
|
(b :initarg :b1) |
522 |
|
(c :initarg :c1) |
523 |
|
(d :initarg :d1)) |
524 |
|
(:default-initargs :a1 10 :b1 20)) |
525 |
|
|
526 |
|
(defclass class-0217b (class-0217a) |
527 |
|
() |
528 |
|
(:default-initargs :a1 30 :c1 40)) |
529 |
|
|
530 |
|
(deftest class-0217.1 |
531 |
|
(let ((c (make-instance 'class-0217a))) |
532 |
|
(values |
533 |
|
(map-slot-boundp* c '(a b c d)) |
534 |
|
(map-slot-value c '(a b)))) |
535 |
|
(t t nil nil) |
536 |
|
(10 20)) |
537 |
|
|
538 |
|
(deftest class-0217.2 |
539 |
|
(let ((c (make-instance 'class-0217a :a1 'x :c1 'y))) |
540 |
|
(values |
541 |
|
(map-slot-boundp* c '(a b c d)) |
542 |
|
(map-slot-value c '(a b c)))) |
543 |
|
(t t t nil) |
544 |
|
(x 20 y)) |
545 |
|
|
546 |
|
(deftest class-0217.3 |
547 |
|
(let ((c (make-instance 'class-0217b))) |
548 |
|
(values |
549 |
|
(map-slot-boundp* c '(a b c d)) |
550 |
|
(map-slot-value c '(a b c)))) |
551 |
|
(t t t nil) |
552 |
|
(30 20 40)) |
553 |
|
|
554 |
|
(deftest class-0217.4 |
555 |
|
(let ((c (make-instance 'class-0217b :a1 'x :d1 'y))) |
556 |
|
(values |
557 |
|
(map-slot-boundp* c '(a b c d)) |
558 |
|
(map-slot-value c '(a b c d)))) |
559 |
|
(t t t t) |
560 |
|
(x 20 40 y)) |
561 |
|
|
562 |
|
;;; |
563 |
|
|
564 |
|
(defclass class-0218a () |
565 |
|
((a :initarg :a1)) |
566 |
|
(:default-initargs :a1 'x)) |
567 |
|
|
568 |
|
(defclass class-0218b (class-0218a) |
569 |
|
((a :initform 'y))) |
570 |
|
|
571 |
|
(deftest class-0218.1 |
572 |
|
(let ((c (make-instance 'class-0218a))) |
573 |
|
(slot-value c 'a)) |
574 |
|
x) |
575 |
|
|
576 |
|
(deftest class-0218.2 |
577 |
|
(let ((c (make-instance 'class-0218b))) |
578 |
|
(slot-value c 'a)) |
579 |
|
x) |
580 |
|
|
581 |
|
;;; |
582 |
|
|
583 |
|
(declaim (special *class-0219-a-1* *class-0219-a-2*)) |
584 |
|
|
585 |
|
(defclass class-0219a () |
586 |
|
((a :initarg :a1)) |
587 |
|
(:default-initargs :a1 (setf *class-0219-a-1* 'x))) |
588 |
|
|
589 |
|
(defclass class-0219b () |
590 |
|
((a :initarg :a1)) |
591 |
|
(:default-initargs :a1 (setf *class-0219-a-2* 'y))) |
592 |
|
|
593 |
|
(deftest class-0219.1 |
594 |
|
(let ((*class-0219-a-1* nil)) |
595 |
|
(values |
596 |
|
(slot-value (make-instance 'class-0219a) 'a) |
597 |
|
*class-0219-a-1*)) |
598 |
|
x x) |
599 |
|
|
600 |
|
(deftest class-0219.2 |
601 |
|
(let ((*class-0219-a-1* nil) |
602 |
|
(*class-0219-a-2* nil)) |
603 |
|
(values |
604 |
|
(slot-value (make-instance 'class-0219b) 'a) |
605 |
|
*class-0219-a-1* |
606 |
|
*class-0219-a-2*)) |
607 |
|
y nil y) |
608 |
|
|
609 |
|
;;; |
610 |
|
|
611 |
|
(defclass class-0220a () |
612 |
|
((a :type (integer 0 10) :initarg :a))) |
613 |
|
|
614 |
|
(defclass class-0220b (class-0220a) |
615 |
|
((a :type (integer -5 5)))) |
616 |
|
|
617 |
|
(deftest class-0220.1 |
618 |
|
(slot-value (make-instance 'class-0220a :a 10) 'a) |
619 |
|
10) |
620 |
|
|
621 |
|
(deftest class-0220.2 |
622 |
|
(slot-value (make-instance 'class-0220a :a 0) 'a) |
623 |
|
0) |
624 |
|
|
625 |
|
(deftest class-0220.3 |
626 |
|
(slot-value (make-instance 'class-0220b :a 0) 'a) |
627 |
|
0) |
628 |
|
|
629 |
|
(deftest class-0220.4 |
630 |
|
(slot-value (make-instance 'class-0220b :a 5) 'a) |
631 |
|
5) |
632 |
|
|
633 |
|
;;; |
634 |
|
|
635 |
|
(defclass class-0221a () |
636 |
|
(a b c) |
637 |
|
(:documentation "This is class class-0221a")) |
638 |
|
|
639 |
|
(defclass class-0221b (class-0221a) |
640 |
|
()) |
641 |
|
|
642 |
|
(defclass class-0221c (class-0221a) |
643 |
|
() |
644 |
|
(:documentation "This is class class-0221c")) |
645 |
|
|
646 |
|
(deftest class-0221.1 |
647 |
|
(let* ((cl (find-class 'class-0221a)) |
648 |
|
(doc (documentation cl t))) |
649 |
|
(or (null doc) |
650 |
|
(equalt doc "This is class class-0221a"))) |
651 |
|
t) |
652 |
|
|
653 |
|
(deftest class-0221.2 |
654 |
|
(let* ((cl (find-class 'class-0221b)) |
655 |
|
(doc (documentation cl t))) |
656 |
|
doc) |
657 |
|
nil) |
658 |
|
|
659 |
|
(deftest class-0221.3 |
660 |
|
(let* ((cl (find-class 'class-0221c)) |
661 |
|
(doc (documentation cl t))) |
662 |
|
(or (null doc) |
663 |
|
(equalt doc "This is class class-0221c"))) |
664 |
|
t) |
665 |
|
|
666 |
|
;;; |
667 |
|
|
668 |
|
(defclass class-0222a () |
669 |
|
((s1 :reader s1-r :writer s1-w :accessor s1-acc))) |
670 |
|
|
671 |
|
(defclass class-0222b (class-0222a) |
672 |
|
()) |
673 |
|
|
674 |
|
(deftest class-0222.1 |
675 |
|
(let ((c (make-instance 'class-0222a))) |
676 |
|
(values |
677 |
|
(s1-w 'x c) |
678 |
|
(s1-r c) |
679 |
|
(s1-acc c) |
680 |
|
(setf (s1-acc c) 'y) |
681 |
|
(s1-r c))) |
682 |
|
x x x y y) |
683 |
|
|
684 |
|
(deftest class-0222.2 |
685 |
|
(let ((c (make-instance 'class-0222b))) |
686 |
|
(values |
687 |
|
(s1-w 'x c) |
688 |
|
(s1-r c) |
689 |
|
(s1-acc c) |
690 |
|
(setf (s1-acc c) 'y) |
691 |
|
(s1-r c))) |
692 |
|
x x x y y) |
693 |
|
|
694 |
|
;;; |
695 |
|
|
696 |
|
(defclass class-0223a () |
697 |
|
((s1 :reader s-r :writer s-w :accessor s-acc))) |
698 |
|
|
699 |
|
(defclass class-0223b (class-0223a) |
700 |
|
((s2 :reader s-r :writer s-w :accessor s-acc))) |
701 |
|
|
702 |
|
(deftest class-0223.1 |
703 |
|
(let ((c (make-instance 'class-0223b))) |
704 |
|
(values |
705 |
|
(setf (slot-value c 's1) 'x) |
706 |
|
(setf (slot-value c 's2) 'y) |
707 |
|
(s-r c) |
708 |
|
(s-acc c) |
709 |
|
(s-w 'z c) |
710 |
|
(slot-value c 's1) |
711 |
|
(slot-value c 's2) |
712 |
|
(s-r c) |
713 |
|
(s-acc c))) |
714 |
|
x y y y z x z z z) |
715 |
|
|