← Back to branch summary

~ubuntu-branches/ubuntu/hardy/uim/hardy

« back to all changes in this revision

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

  • Committer: Bazaar Package Importer
  • Author(s): Masahito Omote
  • Date: 2007-04-21 03:46:09 UTC
  • mfrom: (1.1.6 upstream)
  • Revision ID: james.westby@ubuntu.com-20070421034609-gpcurkutp8vaysqj
Tags: 1:1.4.1-3
* Switch to dh_gtkmodules for the gtk 2.10 transition (Closes:
  #419318)
  - debian/control: Add ${misc:Depends} and remove libgtk2.0-bin on
    uim-gtk2.0.
  - debian/uim-gtk2.0.post{inst,rm}: Removed.

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 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
(use srfi-2)
 
37
 
 
38
(if (not (provided? "srfi-2"))
 
39
    (test-skip "SRFI-2 is not enabled"))
 
40
 
 
41
(define tn test-name)
 
42
 
 
43
;; (and-let* <claws> <body>)
 
44
;; 
 
45
;; <claws> ::= '() | (cons <claw> <claws>)
 
46
;; <claw>  ::=  (<variable> <expression>) | (<expression>)
 
47
;;              | <bound-variable>
 
48
 
 
49
(define true #t)
 
50
(define false #f)
 
51
 
 
52
(tn "and-let* invalid form")
 
53
(assert-error (tn) (lambda () (and-let* ((#t) . #t) #t)))
 
54
(assert-error (tn) (lambda () (and-let* ((foo #t) . #t) #t)))
 
55
 
 
56
; and-let*
 
57
(assert-true  "and-let* test 1" (and-let* () #t))
 
58
(assert-true  "and-let* test 2" (and-let* () #t #t))
 
59
(assert-true  "and-let* test 3" (and-let* () #t #t #t))
 
60
(assert-false "and-let* test 4" (and-let* () #f))
 
61
(assert-false "and-let* test 5" (and-let* () #t #f))
 
62
(assert-false "and-let* test 6" (and-let* () #t #t #f))
 
63
(assert-false "and-let* test 7" (and-let* ((false (< 2 1)))
 
64
                                          #t))
 
65
(assert-false "and-let* test 8" (and-let* ((true  (< 1 2))
 
66
                                           (false (< 2 1)))
 
67
                                          #t))
 
68
(assert-true  "and-let* test 9" (and-let* ((one 1)
 
69
                                           (two (+ one 1))
 
70
                                           (three (+ two 1)))
 
71
                                          (= three 3)))
 
72
(assert-false "and-let* test 10" (and-let* ((one 1)
 
73
                                            (two (+ one 1))
 
74
                                            (three (+ two 1)))
 
75
                                           (= three 4)))
 
76
 
 
77
;; <bound-variable> style claw
 
78
(assert-true  "and-let* #11" (and-let* (true)
 
79
                               'ok))
 
80
(assert-true  "and-let* #12" (and-let* (even?)
 
81
                               'ok))
 
82
(assert-false "and-let* #13" (and-let* (false)
 
83
                               'ok))
 
84
(assert-true  "and-let* #14" (and-let* (even?
 
85
                                        true)
 
86
                               'ok))
 
87
(assert-false "and-let* #15" (and-let* (even?
 
88
                                        true
 
89
                                        false)
 
90
                               'ok))
 
91
 
 
92
;; (<expression>) style claw
 
93
(assert-true  "and-let* #16" (and-let* ((#t))
 
94
                               'ok))
 
95
(assert-false "and-let* #17" (and-let* ((#f))
 
96
                               'ok))
 
97
(assert-true  "and-let* #18" (and-let* (((integer? 1)))
 
98
                               'ok))
 
99
(assert-false "and-let* #19" (and-let* (((integer? #t)))
 
100
                               'ok))
 
101
(assert-true  "and-let* #20" (and-let* (((integer? 1))
 
102
                                        ((integer? 2)))
 
103
                               'ok))
 
104
(assert-false "and-let* #21" (and-let* (((integer? 1))
 
105
                                        ((integer? 2))
 
106
                                        ((integer? #t)))
 
107
                               'ok))
 
108
;; procedure itself as value
 
109
(assert-true "and-let* #22" (and-let* ((even?))
 
110
                               'ok))
 
111
 
 
112
;; combined form
 
113
(assert-true  "and-let* #23" (and-let* (true
 
114
                                        even?
 
115
                                        ((integer? 1)))
 
116
                               'ok))
 
117
(assert-true  "and-let* #24" (and-let* (true
 
118
                                        even?
 
119
                                        ((integer? 1))
 
120
                                        (foo '(1 2 3))
 
121
                                        ((list? foo))
 
122
                                        (bar foo))
 
123
                               'ok))
 
124
(assert-false "and-let* #25" (and-let* (true
 
125
                                        even?
 
126
                                        ((integer? 1))
 
127
                                        (foo '#(1 2 3))
 
128
                                        ((list? foo))
 
129
                                        (bar foo))
 
130
                               'ok))
 
131
(assert-false "and-let* #26" (and-let* (true
 
132
                                        even?
 
133
                                        ((integer? 1))
 
134
                                        (foo '(1 2 3))
 
135
                                        (bar (car foo))
 
136
                                        bar
 
137
                                        ((null? bar)))
 
138
                               'ok))
 
139
 
 
140
(total-report)