Author: yamakenz
Date: Sat Sep 1 00:19:09 2007
New Revision: 4933
Added:
sigscheme-trunk/test/test-unittest.scm
Modified:
sigscheme-trunk/test/Makefile.am
sigscheme-trunk/test/unittest.scm
Log:
* test/unittest.scm
- Add SRFI-64 compatibilities
- (test-begin, test-end, test-assert, test-equal, test-eqv, test-eq,
%test-equal, test-error, ): New macro
- (%test-equal2, test-read-eval-string): New procedure
* test/test-unittest.scm
- New file
- Add various tests for the SRFI-64 compatibilities of unittest.scm
* test/Makefile.am
- (sscm_tests): Add test-unittest.scm
Modified: sigscheme-trunk/test/Makefile.am
==============================================================================
--- sigscheme-trunk/test/Makefile.am (original)
+++ sigscheme-trunk/test/Makefile.am Sat Sep 1 00:19:09 2007
@@ -61,6 +61,7 @@
test-symbol.scm \
test-syntax-rules.scm \
test-syntax.scm \
+ test-unittest.scm \
test-values.scm \
test-vector.scm
Added: sigscheme-trunk/test/test-unittest.scm
==============================================================================
--- (empty file)
+++ sigscheme-trunk/test/test-unittest.scm Sat Sep 1 00:19:09 2007
@@ -0,0 +1,130 @@
+;; Filename : test-unittest.scm
+;; About : unit tests for unittest.scm
+;;
+;; Copyright (c) 2007 SigScheme Project <uim-en AT googlegroups.com>
+;;
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;; 3. Neither the name of authors nor the names of its contributors
+;; may be used to endorse or promote products derived from this software
+;; without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(load "./test/unittest.scm")
+
+(require-extension (srfi 23))
+
+(define *test-track-progress* #f)
+(define tn test-name)
+
+;; Uncomment this to test these failure cases.
+;;(provide "test-assertion-failures")
+(cond-expand
+ (test-assertion-failures
+ (test-begin "SRFI-64 compatible assertions failure cases")
+ (test-assert #f)
+ (test-assert (not #t))
+ (test-equal #t #f)
+ (test-equal 'symbol 'another-symbol)
+ (test-equal 3 4)
+ (test-equal (+ 2 3) (+ 4 5))
+ (test-equal '(+ 2 3) '(+ 4 5))
+ (test-equal "string" "another-string")
+ (test-eqv #t #f)
+ (test-eqv 'symbol 'another-symbol)
+ (test-eqv 3 4)
+ (test-eqv (+ 2 3) (+ 4 5))
+ (test-eqv (list + 2 3) (list + 2 3))
+ (test-eqv (string-copy "string") (string-copy "string"))
+ (test-eq #t #f)
+ (test-eq 'symbol 'another-symbol)
+ (test-eq (string-copy "string") (string-copy "string"))
+ (test-error 1)
+ (test-error 'symbol)
+ (test-error (+ 1 2))
+ (test-end))
+ (else #t))
+
+(test-begin "SRFI-64 compatible assertions with implicit test name")
+(test-assert #t)
+(test-assert '(not #t))
+(test-equal #t #t)
+(test-equal #f #f)
+(test-equal 'symbol 'symbol)
+(test-equal 3 3)
+(test-equal (+ 2 3) (+ 1 4))
+(test-equal '(+ 2 3) '(+ 2 3))
+(test-equal "string" "string")
+(test-eqv #t #t)
+(test-eqv #f #f)
+(test-eqv 'symbol 'symbol)
+(test-eqv 3 3)
+(test-eqv (+ 2 3) (+ 1 4))
+(test-eq #t #t)
+(test-eq #f #f)
+(test-eq 'symbol 'symbol)
+(test-error (map))
+(test-error (+ "1" "2"))
+(test-error (error "an user error"))
+(test-end)
+
+(test-begin "SRFI-64 compatible assertions with explicit test name")
+(test-assert (tn) #t)
+(test-assert (tn) '(not #t))
+(test-equal (tn) #t #t)
+(test-equal (tn) #f #f)
+(test-equal (tn) 'symbol 'symbol)
+(test-equal (tn) 3 3)
+(test-equal (tn) (+ 2 3) (+ 1 4))
+(test-equal (tn) '(+ 2 3) '(+ 2 3))
+(test-equal (tn) "string" "string")
+(test-eqv (tn) #t #t)
+(test-eqv (tn) #f #f)
+(test-eqv (tn) 'symbol 'symbol)
+(test-eqv (tn) 3 3)
+(test-eqv (tn) (+ 2 3) (+ 1 4))
+(test-eq (tn) #t #t)
+(test-eq (tn) #f #f)
+(test-eq (tn) 'symbol 'symbol)
+(test-error (tn) (map))
+(test-error (tn) (+ "1" "2"))
+(test-error (tn) (error "an user error"))
+(test-end)
+
+(test-begin "test-read-eval-string")
+(test-eqv 3 (test-read-eval-string "(+ 1 2)"))
+(test-equal '(+ 1 2) (test-read-eval-string "'(+ 1 2)"))
+(test-error (test-read-eval-string "(+ 1 2) "))
+(test-error (test-read-eval-string "(+ 1 2"))
+(test-end)
+
+(test-begin "test-read-eval-string SRFI-64 examples")
+(test-equal 7 (test-read-eval-string "(+ 3 4)"))
+(test-error (test-read-eval-string "(+ 3"))
+(test-error (test-read-eval-string "(+ 3 4"))
+(test-error (test-read-eval-string "(+ 3 4) "))
+(test-equal #\newline (test-read-eval-string "#\\newline"))
+(test-error (test-read-eval-string "#\\newlin"))
+(test-end)
+
+(total-report)
Modified: sigscheme-trunk/test/unittest.scm
==============================================================================
--- sigscheme-trunk/test/unittest.scm (original)
+++ sigscheme-trunk/test/unittest.scm Sat Sep 1 00:19:09 2007
@@ -31,6 +31,11 @@
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; This unit-testing library should be replaced with standard SRFI-64 once the
+;; hygienic-macros are well-implemented. To write new tests, use the SRFI-64
+;; compatible assertions contained at the bottom of this file.
+;; -- YamaKen 2007-09-01
+
(cond-expand
(sigscheme
;; To allow --disable-srfi55, don't use require-extension here.
@@ -224,3 +229,77 @@
(define fixnum-bits (and (symbol-bound? 'fixnum-width)
(fixnum-width)))
+
+
+;;
+;; SRFI-64 compatibilities
+;;
+
+;; See test-unittest.scm to understand how to use these.
+
+(cond-expand
+ (sigscheme
+ ;; To allow --disable-srfi55, don't use require-extension here.
+ (%%require-module "sscm-ext"))
+ (else #t))
+
+(define-macro test-begin
+ (lambda (suite-name . opt-count)
+ (let-optionals* opt-count ((count #f))
+ `(test-name ,suite-name))))
+
+(define-macro test-end
+ (lambda args
+ (let-optionals* args ((suite-name #f))
+ '#f)))
+
+(define-macro test-assert
+ (lambda (first . rest)
+ (let-optionals* (reverse (cons first rest)) ((expr #f)
+ (tname '(test-name)))
+ `(assert-true ,tname ,expr))))
+
+(define-macro test-equal
+ (lambda args
+ `(%test-equal equal? . ,args)))
+
+(define-macro test-eqv
+ (lambda args
+ `(%test-equal eqv? . ,args)))
+
+(define-macro test-eq
+ (lambda args
+ `(%test-equal eq? . ,args)))
+
+(define-macro %test-equal
+ (lambda (= second third . rest)
+ (let-optionals* (if (null? rest)
+ (list '(test-name) second third)
+ (cons second (cons third rest)))
+ ((tname #f)
+ (expected #f)
+ (expr #f))
+ `(%test-equal2 ,= ,tname ,expected ,expr))))
+
+(define %test-equal2
+ (lambda (= tname expected actual)
+ (or (assert tname tname (= expected actual))
+ (report-inequality expected actual))))
+
+(define-macro test-error
+ (lambda (first . rest)
+ (let-optionals* (reverse (cons first rest)) ((expr #f)
+ (err-type #t)
+ (tname '(test-name)))
+ `(assert-error ,tname (lambda () ,expr)))))
+
+(define test-read-eval-string
+ (lambda (str)
+ (let* ((port (open-input-string str))
+ (expr (read port)))
+ (if (or (eof-object? expr)
+ (guard (err
+ (else #t))
+ (not (eof-object? (read-char port)))))
+ (error "invalid expression string" str))
+ (eval expr (interaction-environment)))))
