Author: yamakenz
Date: Fri Jun 15 13:50:34 2007
New Revision: 4606
Added:
sigscheme-trunk/test/gauche-let-optionals.scm
- copied, changed from r4605, /vendor/misc/procedure.scm
sigscheme-trunk/test/test-sscm-ext.scm
Modified:
sigscheme-trunk/QALog
sigscheme-trunk/test/Makefile.am
sigscheme-trunk/test/unittest-gauche.scm
Log:
* test/test-sscm-ext.scm
- New file
- Add various tests for let-optionals*
* test/gauche-let-optionals.scm
- New file copied from vendor/misc/procedure.scm
- Adapt let-optionals* tests to SigScheme
- Add some tests
* test/unittest-gauche.scm
- (test*): New procedure
* test/Makefile.am
- (sscm_tests): Add test-sscm-ext.scm
- (imported_tests): gauche-let-optionals.scm
* QALog
- Update
Modified: sigscheme-trunk/QALog
==============================================================================
--- sigscheme-trunk/QALog (original)
+++ sigscheme-trunk/QALog Fri Jun 15 13:50:34 2007
@@ -1025,7 +1025,7 @@
file: module-sscm-ext.c
category: opt
-spec by eyes: [EMAIL PROTECTED], [EMAIL PROTECTED]
+spec by eyes: [EMAIL PROTECTED], [EMAIL PROTECTED], [EMAIL PROTECTED]
spec by tests:
general review: [EMAIL PROTECTED]
64-bit by eyes: [EMAIL PROTECTED]
@@ -1081,6 +1081,11 @@
Log
---
+2007-06-16 YamaKen <yamaken AT bp.iij4u.or.jp>
+ * module-sscm-ext.c
+ - QA done again @r4606 for newly added let-optionals* with
+ test-sscm-ext.scm and gauche-let-optionals.scm
+
2007-06-15 YamaKen <yamaken AT bp.iij4u.or.jp>
* eval.c
* continuation.c
Modified: sigscheme-trunk/test/Makefile.am
==============================================================================
--- sigscheme-trunk/test/Makefile.am (original)
+++ sigscheme-trunk/test/Makefile.am Fri Jun 15 13:50:34 2007
@@ -50,6 +50,7 @@
test-srfi38.scm \
test-srfi48.scm \
test-srfi60.scm \
+ test-sscm-ext.scm \
test-string-cmp.scm \
test-string-core.scm \
test-string-null.scm \
@@ -103,6 +104,7 @@
bigloo-quote.scm \
bigloo-vector.scm \
gauche-euc-jp.scm \
+ gauche-let-optionals.scm \
gauche-primsyn.scm \
oleg-srfi2.scm
Copied: sigscheme-trunk/test/gauche-let-optionals.scm (from r4605,
/vendor/misc/procedure.scm)
==============================================================================
--- /vendor/misc/procedure.scm (original)
+++ sigscheme-trunk/test/gauche-let-optionals.scm Fri Jun 15 13:50:34 2007
@@ -1,85 +1,44 @@
+;; Copyright (c) 2000-2007 Shiro Kawai <[EMAIL PROTECTED]>
;;
-;; test for procedures
+;; 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 the 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
+;; OWNER 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.
-(use gauche.test)
-(test-start "procedures")
+;; ChangeLog
+;;
+;; 2007-06-16 yamaken Copied from Gauche CVS HEAD revision 1.6, adapted
+;; to SigScheme and add some tests
+;;
http://gauche.cvs.sourceforge.net/*checkout*/gauche/Gauche/test/procedure.scm
-;;-------------------------------------------------------------------
-(test-section "combinatorial programming utilities")
+(use sscm-ext)
-(test* "pa$" 10 ((pa$ + 3) 7))
-(test* "pa$" '(a b c)
- ((pa$ list 'a) 'b 'c))
-(test* "pa$" '(a b c)
- ((pa$ list 'a 'b) 'c))
-(test* "pa$" '(a b c)
- ((pa$ (pa$ list 'a) 'b) 'c))
-
-(test "map$" '(2 4 6)
- (lambda ()
- (define map2* (map$ (pa$ * 2)))
- (map2* '(1 2 3))))
-
-(test "compose" '(#t #f #t)
- (lambda ()
- (define not-zero? (compose not zero?))
- (list (not-zero? 3)
- (not-zero? 0)
- (not-zero? -100))))
-
-(test "compose" 'a (lambda () ((compose car) '(a b c))))
-(test "compose" '(a b c) (lambda () ((compose) '(a b c))))
-
-(test "complement" '(#t #f #t)
- (lambda () (map (complement even?) '(1 2 3))))
-(test "complement" '(#t #f #t)
- (lambda () (map (complement zero?) '(-1 0 1))))
-(test "complement" '(#f #t #f)
- (lambda () (map (complement =) '(1 2 3) '(1 1 3))))
-(test "complement" '(#f #t #f)
- (lambda () (map (complement (lambda (x y) (= x y))) '(1 2 3) '(1 1 3))))
-(test "complement" #t
- (lambda () ((complement (lambda () #f)))))
-
-(test "compose, apply$, map$" 32
- (lambda ()
- (define dot-product (compose (apply$ +) (map$ *)))
- (dot-product '(1 2 3) '(4 5 6))))
-
-(test "any-pred" '(#t #t #f)
- (lambda ()
- (define string-or-symbol? (any-pred string? symbol?))
- (list (string-or-symbol? "abc")
- (string-or-symbol? 'abc)
- (string-or-symbol? 3))))
-
-(test "any-pred" '(b c)
- (lambda ()
- ((any-pred (cut memq <> '(a b c))
- (cut memq <> '(1 2 3)))
- 'b)))
-
-(test "any-pred" '(#t #f)
- (lambda ()
- (define <> (any-pred < >))
- (list (<> 3 4)
- (<> 3 3))))
-
-(test "every-pred" '(#t #f #f)
- (lambda ()
- (list ((every-pred odd? positive?) 3)
- ((every-pred odd? positive?) 4)
- ((every-pred odd? positive?) -3))))
-
-(test "every-pred" '(3 #f)
- (lambda ()
- (define safe-length (every-pred list? length))
- (list (safe-length '(a b c))
- (safe-length "aaa"))))
+(load "./test/unittest-gauche.scm")
;;-------------------------------------------------------------------
-(test-section "optional arguments")
+;; (test-section "optional arguments")
(define (oof x . args)
(let-optionals* args ((a 'a)
@@ -87,10 +46,11 @@
(c 'c))
(list x a b c)))
-(test* "let-optionals*" '(0 a b c) (oof 0))
-(test* "let-optionals*" '(0 1 b c) (oof 0 1))
-(test* "let-optionals*" '(0 1 2 c) (oof 0 1 2))
-(test* "let-optionals*" '(0 1 2 3) (oof 0 1 2 3))
+(test* "let-optionals*" '(0 a b c) '(oof 0))
+(test* "let-optionals*" '(0 1 b c) '(oof 0 1))
+(test* "let-optionals*" '(0 1 2 c) '(oof 0 1 2))
+(test* "let-optionals*" '(0 1 2 3) '(oof 0 1 2 3))
+(test* "let-optionals*" '(0 1 2 3) '(oof 0 1 2 3 4))
(define (oof* x . args)
(let-optionals* args ((a 'a)
@@ -98,129 +58,25 @@
. c)
(list x a b c)))
-(test* "let-optionals*" '(0 a b ()) (oof* 0))
-(test* "let-optionals*" '(0 1 b ()) (oof* 0 1))
-(test* "let-optionals*" '(0 1 2 ()) (oof* 0 1 2))
-(test* "let-optionals*" '(0 1 2 (3)) (oof* 0 1 2 3))
+(test* "let-optionals*" '(0 a b ()) '(oof* 0))
+(test* "let-optionals*" '(0 1 b ()) '(oof* 0 1))
+(test* "let-optionals*" '(0 1 2 ()) '(oof* 0 1 2))
+(test* "let-optionals*" '(0 1 2 (3)) '(oof* 0 1 2 3))
+(test* "let-optionals*" '(0 1 2 (3 4)) '(oof* 0 1 2 3 4))
(define (oof+ x . args)
(let ((i 0))
- (let-optionals* (begin (inc! i) args)
+ (let-optionals* (begin (set! i (+ i 1)) args)
((a 'a)
(b 'b)
(c 'c))
i)))
-(test* "let-optionals*" 1 (oof+ 0))
-(test* "let-optionals*" 1 (oof+ 0 1))
-(test* "let-optionals*" 1 (oof+ 0 1 2))
-(test* "let-optionals*" 1 (oof+ 0 1 2 3))
-
-(define (oaf x . args)
- (let ((y (get-optional args 'foof)))
- (list x y)))
-
-(test* "get-optional" '(0 foof) (oaf 0))
-(test* "get-optional" '(0 1) (oaf 0 1))
-
-(define (oaf+ x . args)
- (let ((i 0))
- (let ((y (get-optional (begin (inc! i) args) 'foof)))
- i)))
-
-(test* "get-optional" 1 (oaf+ 0))
-(test* "get-optional" 1 (oaf+ 0 1))
-
-(define (oef x . args)
- (let-keywords* args ((a 'a)
- (b :bb 'b)
- (c 'c))
- (list x a b c)))
-
-(test* "let-keywords*" '(0 a b c) (oef 0))
-(test* "let-keywords*" '(0 1 b c) (oef 0 :a 1))
-(test* "let-keywords*" '(0 a 1 c) (oef 0 :bb 1))
-(test* "let-keywords*" '(0 a b 1) (oef 0 :c 1))
-(test* "let-keywords*" '(0 1 2 3) (oef 0 :c 3 :bb 2 :a 1))
-;;(test* "let-keywords*" *test-error* (oef 0 :c 3 :bb 2 :a 1 :unknown 1))
-
-(define (oef+ x . args)
- (let ((i 0))
- (let-keywords* (begin (inc! i) args)
- ((a 'a)
- (b :bb 'b)
- (c 'c))
- i)))
-
-(test* "let-keywords*" 1 (oef+ 0))
-(test* "let-keywords*" 1 (oef+ 0 :a 1))
-(test* "let-keywords*" 1 (oef+ 0 :bb 1))
-(test* "let-keywords*" 1 (oef+ 0 :c 1))
-(test* "let-keywords*" 1 (oef+ 0 :c 3 :bb 2 :a 1))
-;;(test* "let-keywords*" *test-error* (oef+ 0 :c 3 :bb 2 :a 1 :unknown 1))
-
-(define (orf x . args)
- (let-keywords args ((a 'a)
- (b :bb 'b)
- (c 'c))
- (list x a b c)))
-
-(test* "let-keywords" '(0 a b c) (orf 0))
-(test* "let-keywords" '(0 1 b c) (orf 0 :a 1))
-(test* "let-keywords" '(0 a 1 c) (orf 0 :bb 1))
-(test* "let-keywords" '(0 a b 1) (orf 0 :c 1))
-(test* "let-keywords" '(0 1 2 3) (orf 0 :c 3 :bb 2 :a 1))
-(test* "let-keywords" *test-error* (orf 0 :c 3 :bb 2 :a 1 :unknown 1))
-
-(define (orf+ x . args)
- (let ((i 0))
- (let-keywords (begin (inc! i) args)
- ((a 'a)
- (b :bb 'b)
- (c 'c))
- i)))
+(test* "let-optionals*" 1 '(oof+ 0))
+(test* "let-optionals*" 1 '(oof+ 0 1))
+(test* "let-optionals*" 1 '(oof+ 0 1 2))
+(test* "let-optionals*" 1 '(oof+ 0 1 2 3))
+(test* "let-optionals*" 1 '(oof+ 0 1 2 3 4))
-(test* "let-keywords" 1 (orf+ 0))
-(test* "let-keywords" 1 (orf+ 0 :a 1))
-(test* "let-keywords" 1 (orf+ 0 :bb 1))
-(test* "let-keywords" 1 (orf+ 0 :c 1))
-(test* "let-keywords" 1 (orf+ 0 :c 3 :bb 2 :a 1))
-(test* "let-keywords" *test-error* (orf 0 :c 3 :bb 2 :a 1 :unknown 1))
-
-;; let-keywords* combined with syntax rules
-(define-syntax lambda++
- (syntax-rules ()
- ((lambda++ "sub" () (margs ...) kargs . body)
- (lambda (margs ... . rest)
- (let-keywords* rest kargs
- . body)))
- ((lambda++ "sub" (:key) margs kargs . body)
- (lambda++ "sub" () margs kargs . body))
- ((lambda++ "sub" (:key (arg1 def1) args ...) margs (kargs ...) . body)
- (lambda++ "sub" (:key args ...) margs (kargs ... (arg1 def1)) . body))
- ((lambda++ "sub" (:key arg1 args ...) margs (kargs ...) . body)
- (lambda++ "sub" (:key args ...) margs (kargs ... (arg1 #f)) . body))
- ((lambda++ "sub" (arg1 args ...) (margs ...) kargs . body)
- (lambda++ "sub" (args ...) (margs ... arg1) kargs . body))
- ((lambda++ args . body)
- (lambda++ "sub" args () () . body))
- ))
-
-(test* "macro + let-keywords*" '(1 2 3 #f 5)
- ((lambda++ (a b c :key d e) (list a b c d e))
- 1 2 3 :e 5))
-
-(test* "macro + let-keywords*" *test-error*
- ((lambda++ (a b c :key d e) (list a b c d e))
- 1 2 :d 3))
-
-(test* "macro + let-keywords*" '(1 2 3 4 #f)
- ((lambda++ (a b c :key d e) (list a b c d e))
- 1 2 3 :d 4))
-
-(test* "macro + let-keywords*" '(1 2 3 0 1)
- ((lambda++ (a b c :key (d 0) (e 1)) (list a b c d e))
- 1 2 3))
-
-(test-end)
+(total-report)
Added: sigscheme-trunk/test/test-sscm-ext.scm
==============================================================================
--- (empty file)
+++ sigscheme-trunk/test/test-sscm-ext.scm Fri Jun 15 13:50:34 2007
@@ -0,0 +1,130 @@
+#! /usr/bin/env sscm -C UTF-8
+
+;; Filename : test-sscm-ext.scm
+;; About : unit tests for SigScheme specific extensions
+;;
+;; 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.
+
+(use sscm-ext)
+
+(load "test/unittest.scm")
+
+(if (not (symbol-bound? 'let-optionals*))
+ (test-skip "SigScheme extensions are not enabled"))
+
+(define tn test-name)
+(define ud (undef))
+
+(tn "let-optionals* invalid forms")
+(assert-error (tn) (lambda () (let-optionals* '() ())))
+(assert-error (tn) (lambda () (let-optionals* #(0) () #t)))
+(assert-error (tn) (lambda () (let-optionals* #(0) args args)))
+(assert-error (tn) (lambda () (let-optionals* '() #(0) #t)))
+(assert-error (tn) (lambda () (let-optionals* '() (0) #t)))
+(assert-error (tn) (lambda () (let-optionals* '(0 1 2) (a . 3) #t)))
+
+(tn "let-optionals* null bindings")
+(assert-equal? (tn) 'ok (let-optionals* '() () 'ok))
+(assert-equal? (tn) 'ok (let-optionals* '(0) () 'ok))
+(assert-equal? (tn) 'ok (let-optionals* '(0 1) () 'ok))
+(assert-equal? (tn) 'ok (let-optionals* '(0 1 2) () 'ok))
+
+;; Conforms to the undocumented behavior of Gauche 0.8.8.
+(tn "let-optionals* restvar-only")
+(assert-equal? (tn) '() (let-optionals* '() args args))
+(assert-equal? (tn) '(0) (let-optionals* '(0) args args))
+(assert-equal? (tn) '(0 1) (let-optionals* '(0 1) args args))
+(assert-equal? (tn) '(0 1 2) (let-optionals* '(0 1 2) args args))
+
+(tn "let-optionals* var-only single binding")
+(assert-equal? (tn) (undef) (let-optionals* '() (a) a))
+(assert-equal? (tn) 0 (let-optionals* '(0) (a) a))
+(assert-equal? (tn) 0 (let-optionals* '(0 1) (a) a))
+
+(tn "let-optionals* var-only bindings")
+(assert-equal? (tn) (list ud ud) (let-optionals* '() (a b) (list a b)))
+(assert-equal? (tn) (list 0 ud) (let-optionals* '(0) (a b) (list a b)))
+(assert-equal? (tn) '(0 1) (let-optionals* '(0 1) (a b) (list a b)))
+(assert-equal? (tn) '(0 1) (let-optionals* '(0 1 2) (a b) (list a b)))
+
+(tn "let-optionals* var-only bindings with restvar")
+(assert-equal? (tn) (list ud ud '()) (let-optionals* '() (a b . c) (list
a b c)))
+(assert-equal? (tn) (list 0 ud '()) (let-optionals* '(0) (a b . c) (list
a b c)))
+(assert-equal? (tn) '(0 1 ()) (let-optionals* '(0 1) (a b . c) (list
a b c)))
+(assert-equal? (tn) '(0 1 (2)) (let-optionals* '(0 1 2) (a b . c) (list
a b c)))
+(assert-equal? (tn) '(0 1 (2 3)) (let-optionals* '(0 1 2 3) (a b . c)
(list a b c)))
+
+(tn "let-optionals* var-defaultval single binding")
+(assert-equal? (tn) 'A (let-optionals* '() ((a 'A)) a))
+(assert-equal? (tn) 0 (let-optionals* '(0) ((a 'A)) a))
+(assert-equal? (tn) 0 (let-optionals* '(0 1) ((a 'A)) a))
+
+(tn "let-optionals* var-defaultval bindings")
+(assert-equal? (tn) '(A B) (let-optionals* '() ((a 'A) (b 'B)) (list a
b)))
+(assert-equal? (tn) '(0 B) (let-optionals* '(0) ((a 'A) (b 'B)) (list a
b)))
+(assert-equal? (tn) '(0 1) (let-optionals* '(0 1) ((a 'A) (b 'B)) (list a
b)))
+(assert-equal? (tn) '(0 1) (let-optionals* '(0 1 2) ((a 'A) (b 'B)) (list a
b)))
+
+(tn "let-optionals* var-defaultval bindings with restvar")
+(assert-equal? (tn) '(A B ()) (let-optionals* '() ((a 'A) (b 'B) . c)
(list a b c)))
+(assert-equal? (tn) '(0 B ()) (let-optionals* '(0) ((a 'A) (b 'B) . c)
(list a b c)))
+(assert-equal? (tn) '(0 1 ()) (let-optionals* '(0 1) ((a 'A) (b 'B) . c)
(list a b c)))
+(assert-equal? (tn) '(0 1 (2)) (let-optionals* '(0 1 2) ((a 'A) (b 'B) . c)
(list a b c)))
+(assert-equal? (tn) '(0 1 (2 3)) (let-optionals* '(0 1 2 3) ((a 'A) (b 'B) .
c) (list a b c)))
+
+(tn "let-optionals* sequencial evaluation")
+(assert-equal? (tn)
+ '(2 5 10)
+ (let-optionals* '() ((a 2)
+ (b (+ a 3))
+ (c (* a b)))
+ (list a b c)))
+(assert-equal? (tn)
+ '(3 6 18)
+ (let-optionals* '(3 6) ((a 2)
+ (b (+ a 3))
+ (c (* a b)))
+ (list a b c)))
+
+(tn "let-optionals* normal cases")
+(assert-equal? (tn)
+ '(21 3)
+ (let-optionals* '(7) ((a 2)
+ (b 3))
+ (set! a (* a b))
+ (list a b)))
+(assert-equal? (tn)
+ '(21 3)
+ (let-optionals* '(7) (a
+ (b 3))
+ (set! a (* a b))
+ (list a b)))
+
+(total-report)
Modified: sigscheme-trunk/test/unittest-gauche.scm
==============================================================================
--- sigscheme-trunk/test/unittest-gauche.scm (original)
+++ sigscheme-trunk/test/unittest-gauche.scm Fri Jun 15 13:50:34 2007
@@ -3,3 +3,8 @@
(define test
(lambda (msg ret func)
(assert-equal? msg ret (func))))
+
+;; <expr> must be quoted (not compatible with Gauche's)
+(define test*
+ (lambda (name expected expr . compare)
+ (assert-equal? name expected (eval expr (interaction-environment)))))
