Author: yamakenz
Date: Tue Jun 12 14:48:50 2007
New Revision: 4583
Modified:
sigscheme-trunk/NEWS
sigscheme-trunk/QALog
sigscheme-trunk/src/module-srfi2.c
sigscheme-trunk/test/test-srfi2.scm
Log:
* src/module-srfi2.c
- (scm_s_srfi2_and_letstar):
* Fix body-less forms rejection such as (and-let* ())
* Remove unneeded null environment extension
* test/test-srfi2.scm
- Add various tests
* NEWS
* QALog
- Update
Modified: sigscheme-trunk/NEWS
==============================================================================
--- sigscheme-trunk/NEWS (original)
+++ sigscheme-trunk/NEWS Tue Jun 12 14:48:50 2007
@@ -29,6 +29,8 @@
- Fix unexpected memory exhaustion on negative length on make-string
+ - Fix body-less forms rejection on SRFI-2 and-let* such as (and-let* ())
+
* Others
Modified: sigscheme-trunk/QALog
==============================================================================
--- sigscheme-trunk/QALog (original)
+++ sigscheme-trunk/QALog Tue Jun 12 14:48:50 2007
@@ -266,7 +266,7 @@
r5rs macro.c
r5rs promise.c
srfi module-srfi1.c
- srfi module-srfi2.c
+yyyy yyy srfi module-srfi2.c
yyyy yyy srfi module-srfi6.c
yyyy yyy srfi module-srfi8.c
yyyy yy srfi module-srfi23.c
@@ -926,14 +926,14 @@
file: module-srfi2.c
category: srfi
-spec by eyes:
-spec by tests:
-general review:
-64-bit by eyes:
-64-bit by tests:
-coding style:
-normal case tests:
-corner case tests:
+spec by eyes: [EMAIL PROTECTED]
+spec by tests: [EMAIL PROTECTED]
+general review: [EMAIL PROTECTED]
+64-bit by eyes: [EMAIL PROTECTED]
+64-bit by tests:
+coding style: [EMAIL PROTECTED]
+normal case tests: [EMAIL PROTECTED]
+corner case tests: [EMAIL PROTECTED]
file: module-srfi6.c
category: srfi
@@ -1081,6 +1081,10 @@
Log
---
+2007-06-13 YamaKen <yamaken AT bp.iij4u.or.jp>
+ * module-srfi2.c
+ - QA done @r4583 with test-srfi2.scm and oleg-srfi2.scm
+
2007-05-29 YamaKen <yamaken AT bp.iij4u.or.jp>
* module-srfi8.c
- QA done @r4572 with test-srfi8.scm
Modified: sigscheme-trunk/src/module-srfi2.c
==============================================================================
--- sigscheme-trunk/src/module-srfi2.c (original)
+++ sigscheme-trunk/src/module-srfi2.c Tue Jun 12 14:48:50 2007
@@ -82,7 +82,7 @@
<claw> ::= (<variable> <expression>) | (<expression>)
| <bound-variable>
=======================================================================*/
- if (CONSP(claws)) {
+ val = SCM_TRUE;
FOR_EACH (claw, claws) {
if (CONSP(claw)) {
if (NULLP(CDR(claw))) {
@@ -116,15 +116,18 @@
}
if (!NULLP(claws))
goto err;
- } else if (NULLP(claws)) {
- env = scm_extend_environment(SCM_NULL, SCM_NULL, env);
- } else {
- goto err;
- }
eval_state->env = env;
- return scm_s_body(body, eval_state);
+ /* SRFI-2 Formal (Denotational) Semantics:
+ * eval[ (AND-LET* (CLAW) ), env] = eval_claw[ CLAW, env ]
+ * eval[ (AND-LET* () ), env] = #t */
+ if (NULLP(body)) {
+ eval_state->ret_type = SCM_VALTYPE_AS_IS;
+ return val;
+ } else {
+ return scm_s_body(body, eval_state);
+ }
err:
ERR_OBJ("invalid claws form", claws);
Modified: sigscheme-trunk/test/test-srfi2.scm
==============================================================================
--- sigscheme-trunk/test/test-srfi2.scm (original)
+++ sigscheme-trunk/test/test-srfi2.scm Tue Jun 12 14:48:50 2007
@@ -31,6 +31,8 @@
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+;; See also oleg-srfi2.scm
+
(load "./test/unittest.scm")
(use srfi-2)
@@ -50,94 +52,154 @@
(define false #f)
(tn "and-let* invalid forms")
-(assert-error (tn) (lambda () (and-let* ((#t) . #t) #t)))
-(assert-error (tn) (lambda () (and-let* ((foo #t) . #t) #t)))
+(assert-error (tn) (lambda () (and-let*)))
+(assert-error (tn) (lambda () (and-let* #t #t)))
+(assert-error (tn) (lambda () (and-let* ((#t) . #t) #t)))
+(assert-error (tn) (lambda () (and-let* ((foo #t) . #t) #t)))
+(assert-error (tn) (lambda () (and-let* ((foo . #t)) #t)))
+(assert-error (tn) (lambda () (and-let* ((foo #t . #t)) #t)))
+(assert-error (tn) (lambda () (and-let* (1) #t)))
(tn "and-let* misc normal forms")
-(assert-true (tn) (and-let* () #t))
-(assert-true (tn) (and-let* () #t #t))
-(assert-true (tn) (and-let* () #t #t #t))
-(assert-false (tn) (and-let* () #f))
-(assert-false (tn) (and-let* () #t #f))
-(assert-false (tn) (and-let* () #t #t #f))
+(assert-eq? (tn) #t (and-let* ()))
+(assert-eq? (tn) 'ok (and-let* ((foo 'ok)) foo))
+(assert-eq? (tn) #t (and-let* () #t))
+(assert-eq? (tn) #t (and-let* () #t #t))
+(assert-eq? (tn) #t (and-let* () #t #t #t))
+(assert-false (tn) (and-let* () #f))
+(assert-false (tn) (and-let* () #t #f))
+(assert-false (tn) (and-let* () #t #t #f))
+(assert-eq? (tn) #t (and-let* () #t #f #t))
(tn "and-let* (<variable> <expression>) style claw")
-(assert-false (tn) (and-let* ((false (< 2 1)))
- #t))
-(assert-false (tn) (and-let* ((true (< 1 2))
- (false (< 2 1)))
- #t))
-(assert-true (tn) (and-let* ((one 1)
- (two (+ one 1))
- (three (+ two 1)))
- (= three 3)))
-(assert-false (tn) (and-let* ((one 1)
- (two (+ one 1))
- (three (+ two 1)))
- (= three 4)))
+(assert-false (tn) (and-let* ((false (< 2 1)))
+ #t))
+(assert-false (tn) (and-let* ((true (< 1 2))
+ (false (< 2 1)))
+ #t))
+(assert-true (tn) (and-let* ((one 1)
+ (two (+ one 1))
+ (three (+ two 1)))
+ (= three 3)))
+(assert-false (tn) (and-let* ((one 1)
+ (two (+ one 1))
+ (three (+ two 1)))
+ (= three 4)))
+(assert-equal? (tn)
+ 6
+ (and-let* ((one 1)
+ (two (+ one 1))
+ (three (+ two 1)))
+ (+ one two three)))
(tn "and-let* <bound-variable> style claw")
-(assert-true (tn) (and-let* (true)
- 'ok))
-(assert-true (tn) (and-let* (even?)
- 'ok))
-(assert-false (tn) (and-let* (false)
- 'ok))
-(assert-true (tn) (and-let* (even?
- true)
- 'ok))
-(assert-false (tn) (and-let* (even?
- true
- false)
- 'ok))
+(assert-eq? (tn) 'ok (and-let* (true)
+ 'ok))
+(assert-eq? (tn) #t (and-let* (true)))
+(assert-eq? (tn) 'ok (and-let* (even?)
+ 'ok))
+(assert-equal? (tn) even? (and-let* (even?)))
+(assert-false (tn) (and-let* (false)
+ 'ok))
+(assert-false (tn) (and-let* (false)))
+(assert-eq? (tn) 'ok (and-let* (even?
+ true)
+ 'ok))
+(assert-eq? (tn) #t (and-let* (even?
+ true)))
+(assert-false (tn) (and-let* (even?
+ true
+ false)
+ 'ok))
+(assert-false (tn) (and-let* (even?
+ true
+ false)))
(tn "and-let* (<expression>) style claw")
-(assert-true (tn) (and-let* ((#t))
- 'ok))
-(assert-false (tn) (and-let* ((#f))
- 'ok))
-(assert-true (tn) (and-let* (((integer? 1)))
- 'ok))
-(assert-false (tn) (and-let* (((integer? #t)))
- 'ok))
-(assert-true (tn) (and-let* (((integer? 1))
- ((integer? 2)))
- 'ok))
-(assert-false (tn) (and-let* (((integer? 1))
- ((integer? 2))
- ((integer? #t)))
- 'ok))
-
-(tn "and-let* procedure itself as value")
-(assert-true (tn) (and-let* ((even?))
- 'ok))
+(assert-eq? (tn) 'ok (and-let* (('ok))))
+(assert-eq? (tn) 'okok (and-let* (('ok)) 'okok))
+(assert-equal? (tn) 1 (and-let* ((1))))
+(assert-equal? (tn) 'ok (and-let* ((1)) 'ok))
+(assert-equal? (tn) "ok" (and-let* (("ok"))))
+(assert-equal? (tn) 'ok (and-let* (("ok")) 'ok))
+(assert-eq? (tn) 'ok (and-let* ((#t))
+ 'ok))
+(assert-false (tn) (and-let* ((#f))
+ 'ok))
+(assert-eq? (tn) 'ok (and-let* (((integer? 1)))
+ 'ok))
+(assert-false (tn) (and-let* (((integer? #t)))
+ 'ok))
+(assert-eq? (tn) 'ok (and-let* (((integer? 1))
+ ((integer? 2)))
+ 'ok))
+(assert-false (tn) (and-let* (((integer? 1))
+ ((integer? 2))
+ ((integer? #t)))
+ 'ok))
(tn "and-let* combined forms")
-(assert-true (tn) (and-let* (true
- even?
- ((integer? 1)))
- 'ok))
-(assert-true (tn) (and-let* (true
- even?
- ((integer? 1))
- (foo '(1 2 3))
- ((list? foo))
- (bar foo))
- 'ok))
-(assert-false (tn) (and-let* (true
- even?
- ((integer? 1))
- (foo '#(1 2 3))
- ((list? foo))
- (bar foo))
- 'ok))
-(assert-false (tn) (and-let* (true
- even?
- ((integer? 1))
- (foo '(1 2 3))
- (bar (car foo))
- bar
- ((null? bar)))
- 'ok))
+(assert-eq? (tn) 'ok (and-let* (true
+ even?
+ ((integer? 1)))
+ 'ok))
+(assert-eq? (tn) 'ok (and-let* (true
+ even?
+ ((integer? 1))
+ (foo '(1 2 3))
+ ((list? foo))
+ (bar foo))
+ 'ok))
+(assert-false (tn) (and-let* (true
+ even?
+ ((integer? 1))
+ (foo '#(1 2 3))
+ ((list? foo))
+ (bar foo))
+ 'ok))
+(assert-false (tn) (and-let* (true
+ even?
+ ((integer? 1))
+ (foo '(1 2 3))
+ (bar (car foo))
+ bar
+ ((null? bar)))
+ 'ok))
+
+(tn "and-let* internal definitions")
+(define foo 1)
+(assert-equal? (tn)
+ 3
+ (and-let* ()
+ (define foo 3)
+ foo))
+(assert-equal? (tn) 1 foo)
+
+(define foo 1)
+(define bar 2)
+(assert-equal? (tn)
+ 5
+ (and-let* ((foo 3)
+ (bar 4))
+ (define foo 5)
+ foo))
+(assert-equal? (tn) 1 foo)
+(assert-equal? (tn) 2 bar)
+
+(define foo 1)
+(assert-equal? (tn)
+ 3
+ (and-let* ((foo 2))
+ (set! foo 3)
+ foo))
+(assert-equal? (tn) 1 foo)
+
+(define foo 1)
+(assert-equal? (tn)
+ 3
+ (and-let* ()
+ (set! foo 3)
+ foo))
+(assert-equal? (tn) 3 foo)
(total-report)
