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

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

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

revision 1.6 by pfdietz, Wed Apr 23 11:12:35 2003 UTC revision 1.7 by pfdietz, Thu Apr 24 03:53:20 2003 UTC
# Line 432  Line 432 
432      (s1 c))      (s1 c))
433    t)    t)
434    
435    ;;; Tests of :default-initargs
436    
437    (defclass class-16 ()
438      ((s1 :initarg :s1))
439      (:default-initargs :s1 'x))
440    
441    (deftest class-16.1
442      (let ((c (make-instance 'class-16)))
443        (slot-value c 's1))
444      x)
445    
446    (deftest class-16.2
447      (let ((c (make-instance 'class-16 :s1 'y)))
448        (slot-value c 's1))
449      y)
450    
451    (deftest class-16.3
452      (let ((c (make-instance 'class-16 :s1 nil)))
453        (slot-value c 's1))
454      nil)
455    
456    ;;;
457    
458    (defclass class-17 ()
459      ((s1 :initarg :s1 :initform 'foo))
460      (:default-initargs :s1 'bar))
461    
462    (deftest class-17.1
463      (let ((c (make-instance 'class-17)))
464        (slot-value c 's1))
465      bar)
466    
467    (deftest class-17.2
468      (let ((c (make-instance 'class-17 :s1 'z)))
469        (slot-value c 's1))
470      z)
471    
472    (deftest class-17.3
473      (let ((c (make-instance 'class-17 :s1 nil)))
474        (slot-value c 's1))
475      nil)
476    
477    ;;;
478    
479    (defclass class-18 ()
480      ((s1 :initarg :s1 :initarg :s1b))
481      (:default-initargs :s1 'x :s1b 'y))
482    
483    (deftest class-18.1
484      (let ((c (make-instance 'class-18)))
485        (slot-value c 's1))
486      x)
487    
488    (deftest class-18.2
489      (let ((c (make-instance 'class-18 :s1 'z)))
490        (slot-value c 's1))
491      z)
492    
493    (deftest class-18.3
494      (let ((c (make-instance 'class-18 :s1 nil)))
495        (slot-value c 's1))
496      nil)
497    
498    (deftest class-18.4
499      (let ((c (make-instance 'class-18 :s1b 'z)))
500        (slot-value c 's1))
501      z)
502    
503    (deftest class-18.5
504      (let ((c (make-instance 'class-18 :s1b nil)))
505        (slot-value c 's1))
506      nil)
507    
508    ;;;
509    
510    (declaim (special *class-19-s1-initvar*))
511    
512    (defclass class-19 ()
513      ((s1 :initarg :s1))
514      (:default-initargs :s1 (setf *class-19-s1-initvar* 'a)))
515    
516    (deftest class-19.1
517      (let* ((*class-19-s1-initvar* nil)
518             (c (make-instance 'class-19)))
519        (declare (special *class-19-s1-initvar*))
520        (values
521         (slot-value c 's1)
522         *class-19-s1-initvar*))
523      a a)
524    
525    (deftest class-19.2
526      (let* ((*class-19-s1-initvar* nil)
527             (c (make-instance 'class-19 :s1 nil)))
528        (declare (special *class-19-s1-initvar*))
529        (values
530         (slot-value c 's1)
531         *class-19-s1-initvar*))
532      nil nil)
533    
534    (deftest class-19.3
535      (let* ((*class-19-s1-initvar* nil)
536             (c (make-instance 'class-19 :s1 'x)))
537        (declare (special *class-19-s1-initvar*))
538        (values
539         (slot-value c 's1)
540         *class-19-s1-initvar*))
541      x nil)
542    
543    ;;;
544    
545    (declaim (special *class-20-s1-initvar-1* *class-20-s1-initvar-2*))
546    
547    (defclass class-20 ()
548      ((s1 :initarg :s1 :initarg :s1b))
549      (:default-initargs :s1 (setf *class-20-s1-initvar-1* 'a)
550                         :s1b (setf *class-20-s1-initvar-2* 'b)))
551    
552    (deftest class-20.1
553      (let* (*class-20-s1-initvar-1*
554             *class-20-s1-initvar-2*
555             (c (make-instance 'class-20)))
556        (declare (special *class-20-s1-initvar-1*
557                          *class-20-s1-initvar-2*))
558        (values
559         (slot-value c 's1)
560         *class-20-s1-initvar-1*
561         *class-20-s1-initvar-2*))
562      a a b)
563    
564    (deftest class-20.2
565      (let* (*class-20-s1-initvar-1*
566             *class-20-s1-initvar-2*
567             (c (make-instance 'class-20 :s1 'x)))
568        (declare (special *class-20-s1-initvar-1*
569                          *class-20-s1-initvar-2*))
570        (values
571         (slot-value c 's1)
572         *class-20-s1-initvar-1*
573         *class-20-s1-initvar-2*))
574      x nil b)
575    
576    (deftest class-20.3
577      (let* (*class-20-s1-initvar-1*
578             *class-20-s1-initvar-2*
579             (c (make-instance 'class-20 :s1b 'y)))
580        (declare (special *class-20-s1-initvar-1*
581                          *class-20-s1-initvar-2*))
582        (values
583         (slot-value c 's1)
584         *class-20-s1-initvar-1*
585         *class-20-s1-initvar-2*))
586      y a nil)
587    
588    ;;;
589    
590    (declaim (special *class-21-s1-initvar-1* *class-21-s1-initvar-2*))
591    
592    (defclass class-21 ()
593      ((s1 :initarg :s1  :initarg :s1b)
594       (s2 :initarg :s1b :initarg :s2))
595      (:default-initargs :s1 (incf *class-21-s1-initvar-1*)
596                         :s1b (incf *class-21-s1-initvar-2*)))
597    
598    (deftest class-21.1
599      (let* ((*class-21-s1-initvar-1* 10)
600             (*class-21-s1-initvar-2* 20)
601             (c (make-instance 'class-21)))
602        (declare (special *class-21-s1-initvar-1*
603                          *class-21-s1-initvar-2*))
604        (values
605         (slot-value c 's1)
606         (slot-value c 's2)
607         *class-21-s1-initvar-1*
608         *class-21-s1-initvar-2*))
609      11 21 11 21)
610    
611    
612    
613    
614    
615    
616        

Legend:
Removed from v.1.6  
changed lines
  Added in v.1.7

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