← Back to branch summary

~ubuntu-branches/ubuntu/maverick/uim/maverick

« back to all changes in this revision

Viewing changes to sigscheme/test/test-srfi2.scm

  • Committer: Bazaar Package Importer
  • Author(s): Masahito Omote
  • Date: 2008-06-25 19:56:33 UTC
  • mfrom: (3.1.18 intrepid)
  • Revision ID: james.westby@ubuntu.com-20080625195633-8jljph4rfq00l8o7
Tags: 1:1.5.1-2
http://bugs.debian.org/482659
http://bugs.debian.org/483078
* uim-tcode: provide tutcode-custom.scm, tutcode-bushudic.scm
  and tutcode-rule.scm (Closes: #482659)
* Fix FTBFS: segv during compile (Closes: #483078).
  I personally think this bug is not specific for uim but is a optimization
  problem on gcc-4.3.1. (https://bugs.freedesktop.org/show_bug.cgi?id=16477)

Show diffs side-by-side

added added

removed removed

Lines of Context:
sigscheme/test/test-srfi2.scm
 
1
;;  Filename : test-srfi2.scm
 
2
;;  About    : unit test for the SRFI-2 'and-let*'
 
3
;;
 
4
;;  Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.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
;; See also oleg-srfi2.scm
 
35
 
 
36
(require-extension (unittest))
 
37
 
 
38
(require-extension (srfi 2))
 
39
 
 
40
(if (not (provided? "srfi-2"))
 
41
    (test-skip "SRFI-2 is not enabled"))
 
42
 
 
43
(define tn test-name)
 
44
 
 
45
;; (and-let* <claws> <body>)
 
46
;; 
 
47
;; <claws> ::= '() | (cons <claw> <claws>)
 
48
;; <claw>  ::=  (<variable> <expression>) | (<expression>)
 
49
;;              | <bound-variable>
 
50
 
 
51
(define true #t)
 
52
(define false #f)
 
53
 
 
54
(tn "and-let* invalid forms")
 
55
(assert-error  (tn) (lambda () (and-let*)))
 
56
(assert-error  (tn) (lambda () (and-let* #t #t)))
 
57
(assert-error  (tn) (lambda () (and-let* ((#t) . #t) #t)))
 
58
(assert-error  (tn) (lambda () (and-let* ((foo #t) . #t) #t)))
 
59
(assert-error  (tn) (lambda () (and-let* ((foo . #t)) #t)))
 
60
(assert-error  (tn) (lambda () (and-let* ((foo #t . #t)) #t)))
 
61
(assert-error  (tn) (lambda () (and-let* (1) #t)))
 
62
 
 
63
(tn "and-let* misc normal forms")
 
64
(assert-eq?    (tn) #t  (and-let* ()))
 
65
(assert-eq?    (tn) 'ok (and-let* ((foo 'ok)) foo))
 
66
(assert-eq?    (tn) #t  (and-let* () #t))
 
67
(assert-eq?    (tn) #t  (and-let* () #t #t))
 
68
(assert-eq?    (tn) #t  (and-let* () #t #t #t))
 
69
(assert-false  (tn)     (and-let* () #f))
 
70
(assert-false  (tn)     (and-let* () #t #f))
 
71
(assert-false  (tn)     (and-let* () #t #t #f))
 
72
(assert-eq?    (tn) #t  (and-let* () #t #f #t))
 
73
 
 
74
(tn "and-let* (<variable> <expression>) style claw")
 
75
(assert-false  (tn) (and-let* ((false (< 2 1)))
 
76
                      #t))
 
77
(assert-false  (tn) (and-let* ((true  (< 1 2))
 
78
                               (false (< 2 1)))
 
79
                      #t))
 
80
(assert-true   (tn) (and-let* ((one 1)
 
81
                               (two (+ one 1))
 
82
                               (three (+ two 1)))
 
83
                      (= three 3)))
 
84
(assert-false  (tn) (and-let* ((one 1)
 
85
                               (two (+ one 1))
 
86
                               (three (+ two 1)))
 
87
                      (= three 4)))
 
88
(assert-equal? (tn)
 
89
               6
 
90
               (and-let* ((one 1)
 
91
                          (two (+ one 1))
 
92
                          (three (+ two 1)))
 
93
                 (+ one two three)))
 
94
 
 
95
(tn "and-let* <bound-variable> style claw")
 
96
(assert-eq?    (tn) 'ok   (and-let* (true)
 
97
                            'ok))
 
98
(assert-eq?    (tn) #t    (and-let* (true)))
 
99
(assert-eq?    (tn) 'ok   (and-let* (even?)
 
100
                            'ok))
 
101
(assert-equal? (tn) even? (and-let* (even?)))
 
102
(assert-false  (tn)       (and-let* (false)
 
103
                            'ok))
 
104
(assert-false  (tn)       (and-let* (false)))
 
105
(assert-eq?    (tn) 'ok   (and-let* (even?
 
106
                                     true)
 
107
                            'ok))
 
108
(assert-eq?    (tn) #t    (and-let* (even?
 
109
                                     true)))
 
110
(assert-false  (tn)       (and-let* (even?
 
111
                                     true
 
112
                                     false)
 
113
                            'ok))
 
114
(assert-false  (tn)       (and-let* (even?
 
115
                                     true
 
116
                                     false)))
 
117
 
 
118
(tn "and-let* (<expression>) style claw")
 
119
(assert-eq?    (tn) 'ok   (and-let* (('ok))))
 
120
(assert-eq?    (tn) 'okok (and-let* (('ok)) 'okok))
 
121
(assert-equal? (tn) 1     (and-let* ((1))))
 
122
(assert-equal? (tn) 'ok   (and-let* ((1)) 'ok))
 
123
(assert-equal? (tn) "ok"  (and-let* (("ok"))))
 
124
(assert-equal? (tn) 'ok   (and-let* (("ok")) 'ok))
 
125
(assert-eq?    (tn) 'ok   (and-let* ((#t))
 
126
                            'ok))
 
127
(assert-false  (tn)       (and-let* ((#f))
 
128
                            'ok))
 
129
(assert-eq?    (tn) 'ok   (and-let* (((integer? 1)))
 
130
                            'ok))
 
131
(assert-false  (tn)       (and-let* (((integer? #t)))
 
132
                            'ok))
 
133
(assert-eq?    (tn) 'ok   (and-let* (((integer? 1))
 
134
                                     ((integer? 2)))
 
135
                            'ok))
 
136
(assert-false  (tn)       (and-let* (((integer? 1))
 
137
                                     ((integer? 2))
 
138
                                     ((integer? #t)))
 
139
                            'ok))
 
140
 
 
141
(tn "and-let* combined forms")
 
142
(assert-eq?    (tn) 'ok   (and-let* (true
 
143
                                     even?
 
144
                                     ((integer? 1)))
 
145
                            'ok))
 
146
(assert-eq?    (tn) 'ok   (and-let* (true
 
147
                                     even?
 
148
                                     ((integer? 1))
 
149
                                     (foo '(1 2 3))
 
150
                                     ((list? foo))
 
151
                                     (bar foo))
 
152
                            'ok))
 
153
(assert-false  (tn)       (and-let* (true
 
154
                                     even?
 
155
                                     ((integer? 1))
 
156
                                     (foo '#(1 2 3))
 
157
                                     ((list? foo))
 
158
                                     (bar foo))
 
159
                            'ok))
 
160
(assert-false  (tn)       (and-let* (true
 
161
                                     even?
 
162
                                     ((integer? 1))
 
163
                                     (foo '(1 2 3))
 
164
                                     (bar (car foo))
 
165
                                     bar
 
166
                                     ((null? bar)))
 
167
                            'ok))
 
168
 
 
169
(tn "and-let* internal definitions")
 
170
(define foo 1)
 
171
(assert-equal? (tn)
 
172
               3
 
173
               (and-let* ()
 
174
                 (define foo 3)
 
175
                 foo))
 
176
(assert-equal? (tn) 1 foo)
 
177
 
 
178
(define foo 1)
 
179
(define bar 2)
 
180
(assert-equal? (tn)
 
181
               5
 
182
               (and-let* ((foo 3)
 
183
                          (bar 4))
 
184
                 (define foo 5)
 
185
                 foo))
 
186
(assert-equal? (tn) 1 foo)
 
187
(assert-equal? (tn) 2 bar)
 
188
 
 
189
(define foo 1)
 
190
(assert-equal? (tn)
 
191
               3
 
192
               (and-let* ((foo 2))
 
193
                 (set! foo 3)
 
194
                 foo))
 
195
(assert-equal? (tn) 1 foo)
 
196
 
 
197
(define foo 1)
 
198
(assert-equal? (tn)
 
199
               3
 
200
               (and-let* ()
 
201
                 (set! foo 3)
 
202
                 foo))
 
203
(assert-equal? (tn) 3 foo)
 
204
 
 
205
(total-report)