/[gcl]/gcl/ansi-tests/change-class.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/change-class.lsp

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

revision 1.5 by pfdietz, Sun May 4 23:00:04 2003 UTC revision 1.6 by pfdietz, Tue May 6 01:48:50 2003 UTC
# Line 357  Line 357 
357    (nil t)    (nil t)
358    k)    k)
359    
360    (deftest change-class.4.5
361      (let* ((class (find-class 'change-class-class-04b))
362             (obj (allocate-instance class)))
363        (values
364         (map-slot-boundp* obj '(a c))
365         (eqt obj (change-class obj class))
366         (map-slot-boundp* obj '(a c))))
367      (nil nil)
368      t
369      (nil nil))
370        
371    
372  ;;; Custom methods for change-class  ;;; Custom methods for change-class
373    
374  (declaim (special *changed-class-on-class-05*))  (declaim (special *changed-class-on-class-05*))
# Line 380  Line 392 
392       *changed-class-on-class-05*))       *changed-class-on-class-05*))
393    t t)    t t)
394    
395    ;;; Method that invokes the standard method with call-next-method
396    
397  (defclass change-class-class-06 ()  (defclass change-class-class-06 ()
398    ((a :initarg :a) (b :initarg :b) (c :initarg :c)))    ((a :initarg :a) (b :initarg :b) (c :initarg :c)))
399    
# Line 419  Line 433 
433    (t nil nil)    (t nil nil)
434    123)    123)
435    
436    ;;; Before method
437    
438    (defclass change-class-class-07 ()
439      ((a :initform 'x :initarg :a)
440       (b :initform 'y :initarg :b)
441       (c :initarg :c)))
442    
443    (defclass change-class-class-07b ()
444      ((a :initform 'aa :initarg :a)
445       (d :initform 'dd :initarg :d)))
446    
447    (defmethod change-class :before
448      ((obj change-class-class-07)
449       (new-class standard-class)
450       &rest initargs &key &allow-other-keys)
451      (declare (ignore initargs))
452      (setf (slot-value obj 'a) 'z)
453      obj)
454    
455    (deftest change-class.7.1
456      (let* ((class (find-class 'change-class-class-07))
457             (obj (allocate-instance class)))
458        (values
459         (map-slot-boundp* obj '(a b c))
460         (eqt obj (change-class obj class))
461         (map-slot-boundp* obj '(a b c))
462         (slot-value obj 'a)))
463      (nil nil nil)
464      t
465      (t nil nil)
466      z)
467    
468    (deftest change-class.7.2
469      (let* ((class (find-class 'change-class-class-07))
470             (obj (allocate-instance class)))
471        (values
472         (map-slot-boundp* obj '(a b c))
473         (eqt obj (change-class obj class :a 10))
474         (map-slot-boundp* obj '(a b c))
475         (slot-value obj 'a)))
476      (nil nil nil)
477      t
478      (t nil nil)
479      10)
480    
481    (deftest change-class.7.3
482      (let* ((class (find-class 'change-class-class-07))
483             (obj (allocate-instance class)))
484        (values
485         (map-slot-boundp* obj '(a b c))
486         (eqt obj (change-class obj class :b 10))
487         (map-slot-boundp* obj '(a b c))
488         (slot-value obj 'a)
489         (slot-value obj 'b)))
490      (nil nil nil)
491      t
492      (t t nil)
493      z 10)
494    
495    (deftest change-class.7.4
496      (let* ((class (find-class 'change-class-class-07))
497             (new-class (find-class 'change-class-class-07b))
498             (obj (allocate-instance class)))
499        (values
500         (eqt obj (change-class obj new-class))
501         (map-slot-boundp* obj '(a d))
502         (slot-value obj 'a)
503         (slot-value obj 'd)))
504      t (t t) z dd)
505    
506    (deftest change-class.7.5
507      (let* ((class (find-class 'change-class-class-07))
508             (new-class (find-class 'change-class-class-07b))
509             (obj (allocate-instance class)))
510        (values
511         (eqt obj (change-class obj new-class :allow-other-keys nil))
512         (map-slot-boundp* obj '(a d))
513         (slot-value obj 'a)
514         (slot-value obj 'd)))
515      t (t t) z dd)
516    
517    (deftest change-class.7.6
518      (let* ((class (find-class 'change-class-class-07))
519             (new-class (find-class 'change-class-class-07b))
520             (obj (allocate-instance class)))
521        (values
522         (eqt obj (change-class obj new-class :allow-other-keys t))
523         (map-slot-boundp* obj '(a d))
524         (slot-value obj 'a)
525         (slot-value obj 'd)))
526      t (t t) z dd)
527    
528    
529    ;;; After method
530    
531    (defclass change-class-class-08 () ((a :initarg :a) (b :initarg :b)))
532    
533    (defmethod change-class :after
534      ((obj standard-object)
535       (class (eql (find-class 'change-class-class-08)))
536       &rest initargs &key &allow-other-keys)
537      (declare (ignore initargs))
538      (setf (slot-value obj 'a) 'z)
539      obj)
540    
541    (deftest change-class.8.1
542      (let* ((class (find-class 'change-class-class-08))
543             (obj (make-instance class)))
544        (values
545         (map-slot-boundp* obj '(a b))
546         (eqt obj (change-class obj class))
547         (map-slot-boundp* obj '(a b))
548         (slot-value obj 'a)))
549      (nil nil)
550      t
551      (t nil)
552      z)
553          
554    (deftest change-class.8.2
555      (let* ((class (find-class 'change-class-class-08))
556             (obj (make-instance class :a 1 :b 2)))
557        (values
558         (map-slot-boundp* obj '(a b))
559         (eqt obj (change-class obj class))
560         (map-slot-boundp* obj '(a b))
561         (slot-value obj 'a)
562         (slot-value obj 'b)))
563      (t t)
564      t
565      (t t)
566      z 2)
567    
568    (deftest change-class.8.3
569      (let* ((class (find-class 'change-class-class-08))
570             (obj (make-instance class)))
571        (values
572         (map-slot-boundp* obj '(a b))
573         (eqt obj (change-class obj class :a 12 :b 17))
574         (map-slot-boundp* obj '(a b))
575         (slot-value obj 'a)
576         (slot-value obj 'b)))
577      (nil nil)
578      t
579      (t t)
580      z 17)
581    
582    ;;; Put around method test here
583    
584    ;;; Put more inheritance tests here
585      
586  ;;; Error tests  ;;; Error tests
587    
588  (deftest change-class.error.1  (deftest change-class.error.1

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

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