update-instance-for-different-class.lsp 2.08 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Mon May  5 19:32:56 2003
;;;; Contains: Tests for UPDATE-INSTANCE-FOR-DIFFERENT-CLASS

(in-package :cl-test)

(defclass uifdc-class-01a () ((a :initarg :a) (b :initarg :b)))
(defclass uifdc-class-01b () (a b))

(defmethod update-instance-for-different-class
  ((from-obj uifdc-class-01a)
   (to-obj uifdc-class-01b)
   &rest initargs &key &allow-other-keys)
  (declare (ignore initargs))
  (when (slot-boundp from-obj 'a)
    (setf (slot-value to-obj 'b)
	  (slot-value from-obj 'a)))
  (when (slot-boundp from-obj 'b)
    (setf (slot-value to-obj 'a)
	  (slot-value from-obj 'b)))
  to-obj)

(deftest update-instance-for-different-class.1
  (let ((obj (make-instance 'uifdc-class-01a))
	(new-class (find-class 'uifdc-class-01b)))
    (values
     (map-slot-boundp* obj '(a b))
     (eqt obj (change-class obj new-class))
     (typep* obj new-class)
     (map-slot-boundp* obj '(a b))))
  (nil nil)
  t t
  (nil nil))

(deftest update-instance-for-different-class.2
  (let ((obj (make-instance 'uifdc-class-01a :a 1))
	(new-class (find-class 'uifdc-class-01b)))
    (values
     (map-slot-boundp* obj '(a b))
     (eqt obj (change-class obj new-class))
     (typep* obj new-class)
     (map-slot-boundp* obj '(a b))
44
     (slot-value obj 'a)
45
46
47
     (slot-value obj 'b)))
  (t nil)
  t t
48
49
50
51
52
53
54
55
56
57
58
59
60
  (t t)
  1 1)

(deftest update-instance-for-different-class.3
  (let ((obj (make-instance 'uifdc-class-01a :b 1))
	(new-class (find-class 'uifdc-class-01b)))
    (values
     (map-slot-boundp* obj '(a b))
     (eqt obj (change-class obj new-class))
     (typep* obj new-class)
     (map-slot-boundp* obj '(a b))
     (slot-value obj 'a)
     (slot-value obj 'b)))
61
  (nil t)
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
  t t
  (t t)
  1 1)

(deftest update-instance-for-different-class.4
  (let ((obj (make-instance 'uifdc-class-01a :a 1 :b 2))
	(new-class (find-class 'uifdc-class-01b)))
    (values
     (map-slot-boundp* obj '(a b))
     (eqt obj (change-class obj new-class))
     (typep* obj new-class)
     (map-slot-boundp* obj '(a b))
     (slot-value obj 'a)
     (slot-value obj 'b)))
  (t t)
  t t
  (t t)
  2 1)


82
83