← Back to branch summary

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

« back to all changes in this revision

Viewing changes to test/unittest.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/unittest.scm
2
2
;;  About    : Simple unit test library
3
3
;;
4
4
;;  Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
 
5
;;  Copyright (c) 2007 SigScheme Project <uim AT freedesktop.org>
5
6
;;
6
7
;;  All rights reserved.
7
8
;;
30
31
;;  NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31
32
;;  SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32
33
 
33
 
(if (provided? "sigscheme")
34
 
    (eval '(begin
35
 
             (define cond-expand cond)
36
 
             (define sigscheme #t))
37
 
          (interaction-environment)))
38
 
 
39
 
(cond-expand
40
 
 (sigscheme
41
 
  (use srfi-34))
42
 
 (else #t))
 
34
;;;; defining a syntax as value is invalid
 
35
;;(if (provided? "sigscheme")
 
36
;;    (eval '(begin
 
37
;;             (define cond-expand cond)
 
38
;;             (define sigscheme #t))
 
39
;;          (interaction-environment)))
 
40
;;
 
41
;;(cond-expand
 
42
;; (sigscheme
 
43
;;  (use srfi-34))
 
44
;; (else #t))
43
45
 
44
46
(define *test-track-progress* #f)  ;; for locationg SEGV point
45
47
(define *total-testsuites* 1)  ;; TODO: introduce test suites and defaults to 0
100
102
            (report-error err-msg)
101
103
            #f)))))
102
104
 
 
105
(define test-skip
 
106
  (lambda (reason)
 
107
    (display "SKIP: ")
 
108
    (display reason)
 
109
    (newline)
 
110
    (exit 77)))  ;; special code for automake
 
111
 
103
112
;;
104
113
;; assertions for test writers
105
114
;;
106
115
 
 
116
(define assert-fail
 
117
  (lambda (test-name err-msg)
 
118
    (assert test-name err-msg #f)))
 
119
 
107
120
(define assert-true
108
121
  (lambda (test-name exp)
109
122
    (assert test-name test-name exp)))
124
137
 
125
138
(define assert-error
126
139
  (lambda (test-name proc)
 
140
    (or (procedure? proc)
 
141
        (error "assert-error: procedure required but got" proc))
127
142
    (let ((errored (guard (err
128
143
                           (else
129
144
                            #t))
156
171
  (lambda ()
157
172
    (for-each values '())))
158
173
 
 
174
;; SigScheme and Gauche surely returns #<eof>
 
175
(define eof
 
176
  (lambda ()
 
177
    (string-read "")))
 
178
 
159
179
(define obj->literal
160
180
  (lambda (obj)
161
181
    (use srfi-6)
188
208
            (set! serial 0)
189
209
            #f)))))
190
210
 
191
 
(define (eval-counter n)
192
 
  (list 'eval-counter (+ n 1)))
 
211
(define print-expected
 
212
  (lambda (expected)
 
213
    (display " expected print: ")
 
214
    (display expected)
 
215
    (newline)
 
216
    (display "   actual print: ")))
 
217
 
 
218
 
 
219
;;
 
220
;; implementation information
 
221
;;
 
222
 
 
223
(define sigscheme? (provided? "sigscheme"))
 
224
 
 
225
(define fixnum-bits (and (symbol-bound? 'fixnum-width)
 
226
                         (fixnum-width)))