Author: yamakenz
Date: Wed Sep 12 09:58:25 2007
New Revision: 4951
Added:
sigscheme-trunk/test/test-srfi0.scm
Modified:
sigscheme-trunk/lib/srfi-0.scm
sigscheme-trunk/lib/unittest.scm
sigscheme-trunk/test/Makefile.am
Log:
[QA] srfi-0.scm
* lib/srfi-0.scm
- (%cond-expand-dummy): New macro
- (cond-expand): Fix allowing non-toplevel cond-expand placement
* test/test-srfi0.scm
- New file
- Add various tests for SRFI-0
* test/Makefile.am
- (sscm_tests): Add test-srfi0.scm
* lib/unittest.scm
- Require SRFI-6 in toplevel cond-expand
- Replace (else #t) clauses in cond-expand with (else). It is legally
defined in SRFI-0
- (obj->literal, string-read): Remove non-toplevel cond-expand
Modified: sigscheme-trunk/lib/srfi-0.scm
==============================================================================
--- sigscheme-trunk/lib/srfi-0.scm (original)
+++ sigscheme-trunk/lib/srfi-0.scm Wed Sep 12 09:58:25 2007
@@ -33,6 +33,9 @@
(require-extension (srfi 23))
+(define-macro %cond-expand-dummy
+ (lambda () #t))
+
(define %cond-expand-feature?
(lambda (feature-exp)
(cond
@@ -72,5 +75,8 @@
(else
(rec (cdr rest)))))))
(if clause
- (cons 'begin (cdr clause))
+ `(begin
+ ;; raise error if cond-expand is placed in non-toplevel
+ (define-macro %cond-expand-dummy (lambda () #t))
+ . ,(cdr clause))
(error "unfulfilled cond-expand"))))))
Modified: sigscheme-trunk/lib/unittest.scm
==============================================================================
--- sigscheme-trunk/lib/unittest.scm (original)
+++ sigscheme-trunk/lib/unittest.scm Wed Sep 12 09:58:25 2007
@@ -39,9 +39,10 @@
(cond-expand
(sigscheme
;; To allow --disable-srfi55, don't use require-extension here.
+ (%%require-module "srfi-6")
(%%require-module "srfi-23")
(%%require-module "srfi-34"))
- (else #t))
+ (else))
(define *test-track-progress* #f) ;; for locating SEGV point
(define *total-testsuites* 1) ;; TODO: introduce test suites and defaults to 0
@@ -180,20 +181,12 @@
(define obj->literal
(lambda (obj)
- (cond-expand
- (sigscheme
- ;; To allow --disable-srfi55, don't use require-extension here.
- (%%require-module "srfi-6")))
(let ((port (open-output-string)))
(write obj port)
(get-output-string port))))
(define string-read
(lambda (str)
- (cond-expand
- (sigscheme
- ;; To allow --disable-srfi55, don't use require-extension here.
- (%%require-module "srfi-6")))
(let ((port (open-input-string str)))
(read port))))
@@ -244,7 +237,7 @@
(sigscheme
;; To allow --disable-srfi55, don't use require-extension here.
(%%require-module "sscm-ext"))
- (else #t))
+ (else))
(define-macro test-begin
(lambda (suite-name . opt-count)
Modified: sigscheme-trunk/test/Makefile.am
==============================================================================
--- sigscheme-trunk/test/Makefile.am (original)
+++ sigscheme-trunk/test/Makefile.am Wed Sep 12 09:58:25 2007
@@ -41,6 +41,7 @@
test-obsolete.scm \
test-pair.scm \
test-quote.scm \
+ test-srfi0.scm \
test-srfi1-another.scm \
test-srfi1-obsolete.scm \
test-srfi2.scm \
Added: sigscheme-trunk/test/test-srfi0.scm
==============================================================================
--- (empty file)
+++ sigscheme-trunk/test/test-srfi0.scm Wed Sep 12 09:58:25 2007
@@ -0,0 +1,66 @@
+;; Filename : test-srfi0.scm
+;; About : unit tests for SRFI-0
+;;
+;; 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.
+
+(require-extension (unittest))
+
+
+(test-begin "cond-expand invalid forms")
+(test-error (cond-expand))
+(test-error (cond-expand (nonexistent)))
+(test-error (cond-expand ((not srfi-0))))
+(test-error (cond-expand ((not))))
+(test-error (cond-expand ((not nonexistent nonexistent))))
+(test-error (cond-expand ((invalid))))
+;; cond-expand may only be placed to toplevel
+(test-error (if #t (cond-expand (else #t))))
+(test-error ((lambda () (cond-expand (else #t)))))
+(test-end)
+
+(test-begin "cond-expand null matched body")
+(test-eq (undef) (eval '(cond-expand (else))
+ (interaction-environment)))
+(test-eq (undef) (eval '(cond-expand (srfi-0))
+ (interaction-environment)))
+(test-eq (undef) (eval '(cond-expand (sigscheme))
+ (interaction-environment)))
+(test-eq (undef) (eval '(cond-expand ((or)) (else))
+ (interaction-environment)))
+(test-eq (undef) (eval '(cond-expand ((and)))
+ (interaction-environment)))
+(test-eq (undef) (eval '(cond-expand ((not nonexistent)))
+ (interaction-environment)))
+(test-end)
+
+(test-begin "cond-expand")
+(test-end)
+
+(test-report-result)
