source: trunk/source/tests/ansi-tests/make-load-form-saving-slots.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 11 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 5.9 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sat May 17 11:54:54 2003
4;;;; Contains: Tests of MAKE-LOAD-FORM-SAVING-SLOTS
5
6(in-package :cl-test)
7
8;;; These are tests of MAKE-LOAD-FORM-SAVING-SLOTS proper; tests involving
9;;; file compilation will be located elsewhere.
10
11
12(defstruct mlfss-01 a b c)
13
14(deftest make-load-form-saving-slots.1
15  (let* ((obj (make-mlfss-01))
16         (forms (multiple-value-list
17                 (make-load-form-saving-slots obj))))
18    (values
19     (length forms)
20     (let ((newobj (eval (first forms))))
21       (eval (subst newobj obj (second forms)))
22       (eqt (class-of obj) (class-of newobj)))))
23  2 t)
24
25(deftest make-load-form-saving-slots.2
26  (let* ((obj (make-mlfss-01))
27         (forms (multiple-value-list
28                 (make-load-form-saving-slots obj :slot-names '(a b)))))
29    (values
30     (length forms)
31     (let ((newobj (eval (first forms))))
32       (eval (subst newobj obj (second forms)))
33       (eqt (class-of obj) (class-of newobj)))))
34  2 t)
35
36(defclass mlfss-02 () ((a :initarg :a) (b :initarg :b) (c :initarg :c)))
37
38(deftest make-load-form-saving-slots.3
39  (let* ((obj (make-instance 'mlfss-02))
40         (forms (multiple-value-list
41                 (make-load-form-saving-slots obj))))
42     (let ((newobj (eval (first forms))))
43       (eval (subst newobj obj (second forms)))
44       (values
45        (length forms)
46        (eqt (class-of obj) (class-of newobj))
47        (map-slot-boundp* newobj '(a b c)))))
48  2 t (nil nil nil))
49
50(deftest make-load-form-saving-slots.4
51  (let* ((obj (make-instance 'mlfss-02 :a 1 :b 'a :c '(x y z)))
52         (forms (multiple-value-list
53                 (make-load-form-saving-slots obj :slot-names '(a b c)))))
54     (let ((newobj (eval (first forms))))
55       (eval (subst newobj obj (second forms)))
56       (values
57        (length forms)
58        (eqt (class-of obj) (class-of newobj))
59        (map-slot-boundp* newobj '(a b c))
60        (map-slot-value newobj '(a b c)))))
61  2 t (t t t) (1 a (x y z)))
62
63
64(deftest make-load-form-saving-slots.5
65  (let* ((obj (make-instance 'mlfss-02 :a #(x y z)))
66         (forms (multiple-value-list
67                 (make-load-form-saving-slots obj :slot-names '(a b)))))
68     (let ((newobj (eval (first forms))))
69       (eval (subst newobj obj (second forms)))
70       (values
71        (length forms)
72        (eqt (class-of obj) (class-of newobj))
73        (map-slot-boundp* newobj '(a b c))
74        (slot-value newobj 'a))))
75  2 t (t nil nil) #(x y z))
76
77(deftest make-load-form-saving-slots.6
78  (let* ((obj (make-instance 'mlfss-02))
79         (forms (multiple-value-list
80                 (make-load-form-saving-slots obj :allow-other-keys nil))))
81     (let ((newobj (eval (first forms))))
82       (eval (subst newobj obj (second forms)))
83       (values
84        (length forms)
85        (eqt (class-of obj) (class-of newobj))
86        (map-slot-boundp* newobj '(a b c)))))
87  2 t (nil nil nil))
88
89;;; If :slot-names is missing, all initialized slots are retained
90(deftest make-load-form-saving-slots.7
91  (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5))
92         (forms (multiple-value-list
93                 (make-load-form-saving-slots obj))))
94     (let ((newobj (eval (first forms))))
95       (eval (subst newobj obj (second forms)))
96       (values
97        (length forms)
98        (eqt (class-of obj) (class-of newobj))
99        (map-slot-boundp* newobj '(a b c))
100        (map-slot-value newobj '(a c)))))
101  2 t (t nil t) ((x) 6/5))
102
103;;; If :slot-names is present, all initialized slots in the list are retained
104(deftest make-load-form-saving-slots.8
105  (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5))
106         (forms (multiple-value-list
107                 (make-load-form-saving-slots obj :slot-names '(c)))))
108     (let ((newobj (eval (first forms))))
109       (eval (subst newobj obj (second forms)))
110       (values
111        (length forms)
112        (eqt (class-of obj) (class-of newobj))
113        (map-slot-boundp* newobj '(a b c))
114        (slot-value newobj 'c))))
115  2 t (nil nil t) 6/5)
116
117;; It takes an :environment parameter
118(deftest make-load-form-saving-slots.9
119  (let* ((obj (make-instance 'mlfss-02 :a 7 :c 64 :b 100))
120         (forms (multiple-value-list
121                 (make-load-form-saving-slots obj :environment nil))))
122     (let ((newobj (eval (first forms))))
123       (eval (subst newobj obj (second forms)))
124       (values
125        (length forms)
126        (eqt (class-of obj) (class-of newobj))
127        (map-slot-boundp* newobj '(a b c))
128        (map-slot-value newobj '(a b c)))))
129  2 t (t t t) (7 100 64))
130
131(defpackage "CL-TEST-MLFSS-PACKAGE" (:use) (:export #:a))
132(defstruct mlfss-03 cl-test-mlfss-package:a)
133
134(deftest make-load-form-savings-slots.10
135  (let* ((obj (make-mlfss-03 :a 17))
136         (forms (multiple-value-list
137                 (make-load-form-saving-slots obj))))
138    (let ((newobj (eval (first forms))))
139      (eval (subst newobj obj (second forms)))
140      (values
141       (mlfss-03-a obj)
142       (length forms)
143       (eqt (class-of obj) (class-of newobj))
144       (mlfss-03-a newobj))))
145  17 2 t 17)
146
147(deftest make-load-form-savings-slots.11
148  (let* ((obj (make-mlfss-03 :a 17))
149         (forms (multiple-value-list
150                 (make-load-form-saving-slots
151                  obj
152                  :slot-names '(cl-test-mlfss-package:a)))))
153    (let ((newobj (eval (first forms))))
154      (eval (subst newobj obj (second forms)))
155      (values
156       (mlfss-03-a obj)
157       (length forms)
158       (eqt (class-of obj) (class-of newobj))
159       (mlfss-03-a newobj))))
160  17 2 t 17)
161
162
163(defstruct mlfss-04 (a 0 :read-only t))
164
165(deftest make-load-form-savings-slots.12
166  (let* ((obj (make-mlfss-04 :a 123))
167         (forms (multiple-value-list
168                 (make-load-form-saving-slots obj))))
169    (let ((newobj (eval (first forms))))
170      (eval (subst newobj obj (second forms)))
171      (values
172       (mlfss-04-a obj)
173       (length forms)
174       (eqt (class-of obj) (class-of newobj))
175       (mlfss-04-a newobj))))
176  123 2 t 123)
177
178
179;;; General error tests
180
181(deftest make-load-form-saving-slots.error.1
182  (signals-error (make-load-form-saving-slots) program-error)
183  t)
184
185(deftest make-load-form-saving-slots.error.2
186  (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02)
187                                               :slot-names)
188                 program-error)
189  t)
190
191(deftest make-load-form-saving-slots.error.3
192  (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02)
193                                               (gensym) t)
194                 program-error)
195  t)
Note: See TracBrowser for help on using the repository browser.