← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to ansi-tests/make-load-form-saving-slots.lsp

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
ansi-tests/make-load-form-saving-slots.lsp
 
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)