/[gcl]/gcl/ansi-tests/defclass-02.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/defclass-02.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.8 by pfdietz, Sat Apr 26 20:20:07 2003 UTC revision 1.9 by pfdietz, Mon Apr 28 02:28:58 2003 UTC
# Line 315  Line 315 
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 ()
# Line 329  Line 353 
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    

Legend:
Removed from v.1.8  
changed lines
  Added in v.1.9

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26