← Back to branch summary

~ubuntu-branches/ubuntu/hardy/sigscheme/hardy-proposed

« back to all changes in this revision

Viewing changes to test/test-values.scm

  • Committer: Bazaar Package Importer
  • Author(s): NIIBE Yutaka
  • Date: 2007-01-29 15:31:24 UTC
  • mfrom: (1.1.3 upstream)
  • Revision ID: james.westby@ubuntu.com-20070129153124-j5fcqyrwcfbczma7
Tags: 0.7.4-1
New upstream release.

Show diffs side-by-side

added added

removed removed

Lines of Context:
test/test-values.scm
 
1
;;  Filename : test-values.scm
 
2
;;  About    : unit tests for multiple values
 
3
;;
 
4
;;  Copyright (C) 2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
 
5
;;  Copyright (c) 2007 SigScheme Project <uim AT freedesktop.org>
 
6
;;
 
7
;;  All rights reserved.
 
8
;;
 
9
;;  Redistribution and use in source and binary forms, with or without
 
10
;;  modification, are permitted provided that the following conditions
 
11
;;  are met:
 
12
;;
 
13
;;  1. Redistributions of source code must retain the above copyright
 
14
;;     notice, this list of conditions and the following disclaimer.
 
15
;;  2. Redistributions in binary form must reproduce the above copyright
 
16
;;     notice, this list of conditions and the following disclaimer in the
 
17
;;     documentation and/or other materials provided with the distribution.
 
18
;;  3. Neither the name of authors nor the names of its contributors
 
19
;;     may be used to endorse or promote products derived from this software
 
20
;;     without specific prior written permission.
 
21
;;
 
22
;;  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
 
23
;;  IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
 
24
;;  THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 
25
;;  PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 
26
;;  CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
 
27
;;  EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
 
28
;;  PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
 
29
;;  PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
 
30
;;  LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 
31
;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 
32
;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
33
 
 
34
(load "test/unittest.scm")
 
35
 
 
36
(define tn test-name)
 
37
 
 
38
 
 
39
;;
 
40
;; values
 
41
;;
 
42
 
 
43
;; These tests use explicit equivalence predicates instead of assert-equal?, to
 
44
;; avoid being affected by multiple-values -specific behavior.
 
45
 
 
46
(tn "values invalid forms")
 
47
;; Normal continuations accept exactly one value only.
 
48
(assert-error  (tn) (lambda () (eq? '() (values))))
 
49
(assert-error  (tn) (lambda () (eq? '() (apply values '()))))
 
50
(assert-error  (tn) (lambda () (eq? '() (values . 1))))
 
51
(assert-error  (tn) (lambda () (eq? '() (values 1 2))))
 
52
(assert-error  (tn) (lambda () (eq? '() (apply values '(1 2)))))
 
53
(assert-error  (tn) (lambda () (eq? '() (values 1 . 2))))
 
54
 
 
55
(tn "values disallowed places")
 
56
;; top-level variable
 
57
(assert-error  (tn) (lambda () (eval '(define foo (values 1 2 3))
 
58
                                     (interaction-environment))))
 
59
(define foo 1)
 
60
(assert-error  (tn) (lambda () (eval '(set! foo (values 1 2 3))
 
61
                                     (interaction-environment))))
 
62
;; internal variable
 
63
(assert-error  (tn) (lambda () (define bar (values 1 2 3))))
 
64
;; others
 
65
(assert-error  (tn) (lambda () (let ((bar (values 1 2 3))) #t)))
 
66
(assert-error  (tn) (lambda () (let* ((bar (values 1 2 3))) #t)))
 
67
(assert-error  (tn) (lambda () (letrec ((bar (values 1 2 3))) #t)))
 
68
(assert-error  (tn) (lambda () (if (values 1 2 3) #t)))
 
69
(assert-error  (tn) (lambda () (and (values 1 2 3) #t)))
 
70
(assert-error  (tn) (lambda () (or (values 1 2 3) #t)))
 
71
(assert-error  (tn) (lambda () (cond ((values 1 2 3) #t) (else #t))))
 
72
(assert-error  (tn) (lambda () (case (values 1 2 3) (else #t))))
 
73
(assert-error  (tn) (lambda () (begin (values 1 2 3) #t)))
 
74
(assert-error  (tn) (lambda () ((lambda () (values 1 2 3) #t))))
 
75
 
 
76
(tn "values")
 
77
;; Exactly one value.
 
78
(assert-true   (tn) (eqv? 1 (values 1)))
 
79
(assert-true   (tn) (eqv? 1 (apply values '(1))))
 
80
(assert-true   (tn) (eq? '() (values '())))
 
81
(assert-true   (tn) (eq? '() (apply values '(()))))
 
82
(assert-true   (tn) (eq? #f (values #f)))
 
83
(assert-true   (tn) (eq? #f (apply values '(#f))))
 
84
 
 
85
;; Returning multiple values in top-level is allowed (SigScheme-specific).
 
86
;; These forms test whether evaluations are passed without blowing up.
 
87
(values)
 
88
(values 1 2 3)
 
89
(apply values '())
 
90
(apply values '(1 2 3))
 
91
(begin
 
92
  (values))
 
93
(begin
 
94
  (values 1 2 3))
 
95
(begin
 
96
  (apply values '()))
 
97
(begin
 
98
  (apply values '(1 2 3)))
 
99
 
 
100
;;
 
101
;; call-with-values
 
102
;;
 
103
 
 
104
(tn "call-with-values invalid forms")
 
105
(assert-error  (tn) (lambda ()
 
106
                      (call-with-values)))
 
107
(assert-error  (tn) (lambda ()
 
108
                      (call-with-values even?)))
 
109
(assert-error  (tn) (lambda ()
 
110
                      (call-with-values even? #t)))
 
111
(assert-error  (tn) (lambda ()
 
112
                      (call-with-values #t even?)))
 
113
 
 
114
(tn "call-with-values")
 
115
(assert-equal? (tn)
 
116
               -1
 
117
               (call-with-values * -))
 
118
 
 
119
(assert-equal? (tn)
 
120
               'ok
 
121
               (call-with-values
 
122
                   (lambda () (values))
 
123
                 (lambda () 'ok)))
 
124
(assert-equal? (tn)
 
125
               '()
 
126
               (call-with-values
 
127
                   (lambda () (values))
 
128
                 (lambda args args)))
 
129
(assert-equal? (tn)
 
130
               'ok
 
131
               (call-with-values
 
132
                   (lambda () (apply values '()))
 
133
                 (lambda () 'ok)))
 
134
(assert-equal? (tn)
 
135
               '()
 
136
               (call-with-values
 
137
                   (lambda () (apply values '()))
 
138
                 (lambda args args)))
 
139
 
 
140
(assert-equal? (tn)
 
141
               1
 
142
               (call-with-values
 
143
                   (lambda () (values 1))
 
144
                 (lambda (x) x)))
 
145
(assert-equal? (tn)
 
146
               '(1)
 
147
               (call-with-values
 
148
                   (lambda () (values 1))
 
149
                 (lambda args args)))
 
150
(assert-equal? (tn)
 
151
               1
 
152
               (call-with-values
 
153
                   (lambda () (apply values '(1)))
 
154
                 (lambda (x) x)))
 
155
(assert-equal? (tn)
 
156
               '(1)
 
157
               (call-with-values
 
158
                   (lambda () (apply values '(1)))
 
159
                 (lambda args args)))
 
160
 
 
161
(assert-equal? (tn)
 
162
               '(1 2)
 
163
               (call-with-values
 
164
                   (lambda () (values 1 2))
 
165
                 (lambda (x y) (list x y))))
 
166
(assert-equal? (tn)
 
167
               '(1 2)
 
168
               (call-with-values
 
169
                   (lambda () (values 1 2))
 
170
                 (lambda args args)))
 
171
(assert-equal? (tn)
 
172
               '(1 2)
 
173
               (call-with-values
 
174
                   (lambda () (apply values '(1 2)))
 
175
                 (lambda (x y) (list x y))))
 
176
(assert-equal? (tn)
 
177
               '(1 2)
 
178
               (call-with-values
 
179
                   (lambda () (apply values '(1 2)))
 
180
                 (lambda args args)))
 
181
 
 
182
(tn "call-with-values by apply")
 
183
(assert-equal? (tn)
 
184
               -1
 
185
               (apply call-with-values (list * -)))
 
186
 
 
187
(assert-equal? (tn)
 
188
               'ok
 
189
               (apply call-with-values
 
190
                      (list (lambda () (values))
 
191
                            (lambda () 'ok))))
 
192
(assert-equal? (tn)
 
193
               '()
 
194
               (apply call-with-values
 
195
                      (list (lambda () (values))
 
196
                            (lambda args args))))
 
197
(assert-equal? (tn)
 
198
               'ok
 
199
               (apply call-with-values
 
200
                      (list (lambda () (apply values '()))
 
201
                            (lambda () 'ok))))
 
202
(assert-equal? (tn)
 
203
               '()
 
204
               (apply call-with-values
 
205
                      (list (lambda () (apply values '()))
 
206
                            (lambda args args))))
 
207
 
 
208
(assert-equal? (tn)
 
209
               1
 
210
               (apply call-with-values
 
211
                      (list (lambda () (values 1))
 
212
                            (lambda (x) x))))
 
213
(assert-equal? (tn)
 
214
               '(1)
 
215
               (apply call-with-values
 
216
                      (list (lambda () (values 1))
 
217
                            (lambda args args))))
 
218
(assert-equal? (tn)
 
219
               1
 
220
               (apply call-with-values
 
221
                      (list (lambda () (apply values '(1)))
 
222
                            (lambda (x) x))))
 
223
(assert-equal? (tn)
 
224
               '(1)
 
225
               (apply call-with-values
 
226
                      (list (lambda () (apply values '(1)))
 
227
                            (lambda args args))))
 
228
 
 
229
(assert-equal? (tn)
 
230
               '(1 2)
 
231
               (apply call-with-values
 
232
                      (list (lambda () (values 1 2))
 
233
                            (lambda (x y) (list x y)))))
 
234
(assert-equal? (tn)
 
235
               '(1 2)
 
236
               (apply call-with-values
 
237
                      (list (lambda () (values 1 2))
 
238
                            (lambda args args))))
 
239
(assert-equal? (tn)
 
240
               '(1 2)
 
241
               (apply call-with-values
 
242
                      (list (lambda () (apply values '(1 2)))
 
243
                            (lambda (x y) (list x y)))))
 
244
(assert-equal? (tn)
 
245
               '(1 2)
 
246
               (apply call-with-values
 
247
                      (list (lambda () (apply values '(1 2)))
 
248
                            (lambda args args))))
 
249
 
 
250
(tn "call-with-values misc")
 
251
;; test whether the variable is properly bound
 
252
(assert-equal? (tn)
 
253
               1
 
254
               ((lambda (n)
 
255
                  (call-with-values
 
256
                      (lambda () (values 2 3 n))
 
257
                    (lambda (dummy1 dummy2 n2)
 
258
                      n2)))
 
259
                1))
 
260
 
 
261
 
 
262
(total-report)