1;;  Filename : test-begin.scm
2;;  About    : unit test for R5RS begin
3;;
4;;  Copyright (C) 2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
5;;  Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
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(require-extension (unittest))
35
36(define *test-track-progress* #f)
37(define tn test-name)
38
39;; R5RS: 7.1.6 Programs and definitions
40;;
41;; <program> --> <command or definition>*
42;; <command or definition> --> <command>
43;;     | <definition>
44;;     | <syntax definition>
45;;     | (begin <command or definition>+)
46;; <definition> --> (define <variable> <expression>)
47;;       | (define (<variable> <def formals>) <body>)
48;;       | (begin <definition>*)
49;; <def formals> --> <variable>*
50;;       | <variable>* . <variable>
51;; <syntax definition> -->
52;;      (define-syntax <keyword> <transformer spec>)
53
54(tn "top-level begin invalid forms")
55;; 'if', 'and', 'or', 'cond', 'case' do not make environment so these
56;; '(begin)'s are not internal definitions and invalid.
57;; See also test-do.scm for more invalid definitions.
58;; See also test-define.scm for top-level definitions.
59(if (provided? "strict-toplevel-definitions")
60    (begin
61      (assert-error  (tn)
62                     (lambda ()
63                       (eval '(if #t (begin))
64                             (interaction-environment))))
65      (assert-error  (tn)
66                     (lambda ()
67                       (eval '(if #f #t (begin))
68                             (interaction-environment))))
69      (assert-error  (tn)
70                     (lambda ()
71                       (eval '(and (begin))
72                             (interaction-environment))))
73      (assert-error  (tn)
74                     (lambda ()
75                       (eval '(or (begin))
76                             (interaction-environment))))
77      (assert-error  (tn)
78                     (lambda ()
79                       (eval '(cond (#t (begin)))
80                             (interaction-environment))))
81      (assert-error  (tn)
82                     (lambda ()
83                       (eval '(cond (else (begin)))
84                             (interaction-environment))))
85      (assert-error  (tn)
86                     (lambda ()
87                       (eval '(case 'key (#t (begin)))
88                             (interaction-environment))))
89      (assert-error  (tn)
90                     (lambda ()
91                       (eval '(case 'key (else (begin)))
92                             (interaction-environment))))))
93
94(tn "top-level begin invalid forms (strict)")
95(if (provided? "strict-toplevel-definitions")
96    (begin
97      (assert-error  (tn)
98                     (lambda ()
99                       (eval '(if #t (begin (define var0 1)))
100                             (interaction-environment))))
101      (assert-error  (tn)
102                     (lambda ()
103                       (eval '(if #t (begin (define var0 1) #t))
104                             (interaction-environment))))
105      (assert-error  (tn)
106                     (lambda ()
107                       (eval '(if #f #t (begin (define var0 1)))
108                             (interaction-environment))))
109      (assert-error  (tn)
110                     (lambda ()
111                       (eval '(if #f #t (begin (define var0 1) #t))
112                             (interaction-environment))))
113      (assert-error  (tn)
114                     (lambda ()
115                       (eval '(and (begin (define var0 1)))
116                             (interaction-environment))))
117      (assert-error  (tn)
118                     (lambda ()
119                       (eval '(and (begin (define var0 1) #t))
120                             (interaction-environment))))
121      (assert-error  (tn)
122                     (lambda ()
123                       (eval '(or (begin (define var0 1)))
124                             (interaction-environment))))
125      (assert-error  (tn)
126                     (lambda ()
127                       (eval '(or (begin (define var0 1) #t))
128                             (interaction-environment))))
129      (assert-error  (tn)
130                     (lambda ()
131                       (eval '(cond (#t (begin (define var0 1))))
132                             (interaction-environment))))
133      (assert-error  (tn)
134                     (lambda ()
135                       (eval '(cond (#t (begin (define var0 1) #t)))
136                             (interaction-environment))))
137      (assert-error  (tn)
138                     (lambda ()
139                       (eval '(cond (else (begin (define var0 1))))
140                             (interaction-environment))))
141      (assert-error  (tn)
142                     (lambda ()
143                       (eval '(cond (else (begin (define var0 1) #t)))
144                             (interaction-environment))))
145      (assert-error  (tn)
146                     (lambda ()
147                       (eval '(case 'key ((key) (begin (define var0 1))))
148                             (interaction-environment))))
149      (assert-error  (tn)
150                     (lambda ()
151                       (eval '(case 'key ((key) (begin (define var0 1) #t)))
152                             (interaction-environment))))
153      (assert-error  (tn)
154                     (lambda ()
155                       (eval '(case 'key (else (begin (define var0 1))))
156                             (interaction-environment))))
157      (assert-error  (tn)
158                     (lambda ()
159                       (eval '(case 'key (else (begin (define var0 1) #t)))
160                             (interaction-environment))))))
161
162(tn "top-level begin invalid forms (strict) 2")
163;; top-level define cannot be placed under a non-begin structure even if
164;; wrapped into top-level begin.
165(if (provided? "strict-toplevel-definitions")
166    (begin
167      (assert-error  (tn)
168                     (lambda ()
169                       (eval '(begin (if #t (begin (define var0 1))))
170                             (interaction-environment))))
171      (assert-error  (tn)
172                     (lambda ()
173                       (eval '(begin (if #t (begin (define var0 1) #t)))
174                             (interaction-environment))))
175      (assert-error  (tn)
176                     (lambda ()
177                       (eval '(begin (if #f #t (begin (define var0 1))))
178                             (interaction-environment))))
179      (assert-error  (tn)
180                     (lambda ()
181                       (eval '(begin (if #f #t (begin (define var0 1) #t)))
182                             (interaction-environment))))
183      (assert-error  (tn)
184                     (lambda ()
185                       (eval '(begin (and (begin (define var0 1))))
186                             (interaction-environment))))
187      (assert-error  (tn)
188                     (lambda ()
189                       (eval '(begin (and (begin (define var0 1) #t)))
190                             (interaction-environment))))
191      (assert-error  (tn)
192                     (lambda ()
193                       (eval '(begin (or (begin (define var0 1))))
194                             (interaction-environment))))
195      (assert-error  (tn)
196                     (lambda ()
197                       (eval '(begin (or (begin (define var0 1) #t)))
198                             (interaction-environment))))
199      (assert-error  (tn)
200                     (lambda ()
201                       (eval '(begin (cond (#t (begin (define var0 1)))))
202                             (interaction-environment))))
203      (assert-error  (tn)
204                     (lambda ()
205                       (eval '(begin (cond (#t (begin (define var0 1) #t))))
206                             (interaction-environment))))
207      (assert-error  (tn)
208                     (lambda ()
209                       (eval '(begin (cond (else (begin (define var0 1)))))
210                             (interaction-environment))))
211      (assert-error  (tn)
212                     (lambda ()
213                       (eval '(begin (cond (else (begin (define var0 1) #t))))
214                             (interaction-environment))))
215      (assert-error  (tn)
216                     (lambda ()
217                       (eval '(begin (case 'key
218                                       ((key) (begin (define var0 1)))))
219                             (interaction-environment))))
220      (assert-error  (tn)
221                     (lambda ()
222                       (eval '(begin (case 'key
223                                       ((key) (begin (define var0 1) #t))))
224                             (interaction-environment))))
225      (assert-error  (tn)
226                     (lambda ()
227                       (eval '(begin (case 'key
228                                       (else (begin (define var0 1)))))
229                             (interaction-environment))))
230      (assert-error  (tn)
231                     (lambda ()
232                       (eval '(begin (case 'key
233                                       (else (begin (define var0 1) #t))))
234                             (interaction-environment))))))
235
236(tn "top-level begin invalid forms (strict) 3")
237(if (provided? "strict-toplevel-definitions")
238    (begin
239      ;; top-level define cannot be placed under a non-begin structure even if
240      ;; wrapped into top-level begin.
241      (assert-error  (tn)
242                     (lambda ()
243                       (eval '(begin (if #t (define var0 1)))
244                             (interaction-environment))))
245      (assert-error  (tn)
246                     (lambda ()
247                       (eval '(begin (if #f #t (define var0 1)))
248                             (interaction-environment))))
249      (assert-error  (tn)
250                     (lambda ()
251                       (eval '(begin (and (define var0 1)))
252                             (interaction-environment))))
253      (assert-error  (tn)
254                     (lambda ()
255                       (eval '(begin (or (define var0 1)))
256                             (interaction-environment))))
257      (assert-error  (tn)
258                     (lambda ()
259                       (eval '(begin (cond (#t (define var0 1))))
260                             (interaction-environment))))
261      (assert-error  (tn)
262                     (lambda ()
263                       (eval '(begin (cond (else (define var0 1))))
264                             (interaction-environment))))
265      (assert-error  (tn)
266                     (lambda ()
267                       (eval '(begin (case 'key ((key) (define var0 1))))
268                             (interaction-environment))))
269      (assert-error  (tn)
270                     (lambda ()
271                       (eval '(begin (case 'key (else (define var0 1))))
272                             (interaction-environment))))
273      ;; test being evaled at non-tail part of 'begin'
274      (assert-error  (tn)
275                     (lambda ()
276                       (eval '(begin (if #t (define var0 1)) #t)
277                             (interaction-environment))))
278      (assert-error  (tn)
279                     (lambda ()
280                       (eval '(begin (if #f #t (define var0 1)) #t)
281                             (interaction-environment))))
282      (assert-error  (tn)
283                     (lambda ()
284                       (eval '(begin (and (define var0 1)) #t)
285                             (interaction-environment))))
286      (assert-error  (tn)
287                     (lambda ()
288                       (eval '(begin (or (define var0 1)) #t)
289                             (interaction-environment))))
290      (assert-error  (tn)
291                     (lambda ()
292                       (eval '(begin (cond (#t (define var0 1))) #t)
293                             (interaction-environment))))
294      (assert-error  (tn)
295                     (lambda ()
296                       (eval '(begin (cond (else (define var0 1))) #t)
297                             (interaction-environment))))
298      (assert-error  (tn)
299                     (lambda ()
300                       (eval '(begin (case 'key ((key) (define var0 1))) #t)
301                             (interaction-environment))))
302      (assert-error  (tn)
303                     (lambda ()
304                       (eval '(begin (case 'key (else (define var0 1))) #t)
305                             (interaction-environment))))))
306
307
308(tn "top-level begin valid forms")
309;; '(begin)' is allowd at toplevel
310(if (provided? "sigscheme")
311    (begin
312      (assert-equal? (tn)
313                     (undef)
314                     (eval '(begin)
315                           (interaction-environment)))
316      (assert-equal? (tn)
317                     (undef)
318                     (eval '(begin (begin))
319                           (interaction-environment)))))
320;; 'begin' does not create an environment
321(assert-false  (tn) (symbol-bound? 'var1))
322(begin
323  (define var1 1))
324(assert-equal? (tn) 1 var1)
325;; duplicate definition is allowed
326(begin
327  (define var1 3))
328(assert-equal? (tn) 3 var1)
329(begin
330  (define var1 4)
331  (define var1 5))
332(assert-equal? (tn) 5 var1)
333;; intermixing expression and definition on top-level is valid
334(begin
335  (+ 1 2)
336  (define var2 1))
337(assert-equal? (tn) 1 var2)
338(begin
339  (define var3 1)
340  (+ 1 2))
341(assert-equal? (tn) 1 var3)
342(begin
343  (define var4 1)
344  (+ 1 2)
345  (begin
346    (define var5 1)))
347(assert-equal? (tn) 1 var4)
348(assert-equal? (tn) 1 var5)
349
350
351(total-report)
352