[uim-commit] r1617 - in branches/r5rs/sigscheme: . test
yamaken at freedesktop.org
yamaken at freedesktop.org
Tue Sep 27 11:14:48 PDT 2005
Author: yamaken
Date: 2005-09-27 11:14:45 -0700 (Tue, 27 Sep 2005)
New Revision: 1617
Modified:
branches/r5rs/sigscheme/TODO
branches/r5rs/sigscheme/operations-srfi2.c
branches/r5rs/sigscheme/test/test-srfi2.scm
Log:
* sigscheme/operations-srfi2.c
- (ScmOp_SRFI2_and_let_star):
* Add some FIXME comments
* Insert a comment about and-let* syntax
* Replace SCM_NULL for variable initialization with SCM_FALSE. See
"Performance improvements" section of the TODO file
* Fix NULLP(binding) with !CONSP(binding) as correct error
checking although it will be obsolete soon by supporting full
and-let* syntax
* sigscheme/test/test-srfi2.scm
- Insert lacking copyright header
- Add tests for <bound-variable> and (<expression>) style claw which
are not supported by SigScheme implementation
- All tests are passed on 'gosh -usrfi-2 test/test-srfi2.scm'
* sigscheme/TODO
- Update
Modified: branches/r5rs/sigscheme/TODO
===================================================================
--- branches/r5rs/sigscheme/TODO 2005-09-27 17:31:33 UTC (rev 1616)
+++ branches/r5rs/sigscheme/TODO 2005-09-27 18:14:45 UTC (rev 1617)
@@ -36,6 +36,8 @@
==============================================================================
Extensions:
+* Fix the SRFI-2 issues
+
==============================================================================
Performance improvements:
Modified: branches/r5rs/sigscheme/operations-srfi2.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi2.c 2005-09-27 17:31:33 UTC (rev 1616)
+++ branches/r5rs/sigscheme/operations-srfi2.c 2005-09-27 18:14:45 UTC (rev 1617)
@@ -61,14 +61,15 @@
/*=======================================
Function Implementations
=======================================*/
+/* FIXME: Simplify Scm_RegisterSyntaxFixedTailRec2 */
ScmObj ScmOp_SRFI2_and_let_star(ScmObj args, ScmEvalState *eval_state)
{
ScmObj env = eval_state->env;
- ScmObj bindings = SCM_NULL;
- ScmObj body = SCM_NULL;
- ScmObj var = SCM_NULL;
- ScmObj val = SCM_NULL;
- ScmObj binding = SCM_NULL;
+ ScmObj bindings = SCM_FALSE;
+ ScmObj body = SCM_FALSE;
+ ScmObj var = SCM_FALSE;
+ ScmObj val = SCM_FALSE;
+ ScmObj binding = SCM_FALSE;
/* sanity check */
if CHECK_2_ARGS(args)
@@ -78,14 +79,22 @@
bindings = CAR(args);
body = CDR(args);
+ /*========================================================================
+ (and-let* <claws> <body>)
+
+ <claws> ::= '() | (cons <claw> <claws>)
+ <claw> ::= (<variable> <expression>) | (<expression>)
+ | <bound-variable>
+ ========================================================================*/
if (CONSP(bindings)) {
for (; !NULLP(bindings); bindings = CDR(bindings)) {
binding = CAR(bindings);
- if (NULLP(binding) || NULLP(CDR(binding)))
+ /* FIXME: Support (<exp>) and <bound-variable> style claw */
+ if (!CONSP(binding) || NULLP(CDR(binding)))
SigScm_ErrorObj("and-let* : invalid binding form : ", binding);
- SCM_SHIFT_RAW_2(var, val, binding);
+ SCM_SHIFT_RAW_2(var, val, binding); /* FIXME: error check */
val = EVAL(val, env);
if (FALSEP(val))
return val;
Modified: branches/r5rs/sigscheme/test/test-srfi2.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi2.scm 2005-09-27 17:31:33 UTC (rev 1616)
+++ branches/r5rs/sigscheme/test/test-srfi2.scm 2005-09-27 18:14:45 UTC (rev 1617)
@@ -1,5 +1,43 @@
+;; FileName : test-srfi2.scm
+;; About : unit test for the SRFI-2 'and-let*'
+;;
+;; Copyright (C) 2005 by Kazuki Ohta (mover at hct.zaq.ne.jp)
+;;
+;; 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")
+;; (and-let* <claws> <body>)
+;;
+;; <claws> ::= '() | (cons <claw> <claws>)
+;; <claw> ::= (<variable> <expression>) | (<expression>)
+;; | <bound-variable>
+
; and-let*
(assert-true "and-let* test 1" (and-let* () #t))
(assert-true "and-let* test 2" (and-let* () #t #t))
@@ -21,4 +59,60 @@
(three (+ two 1)))
(= three 4)))
+;; <bound-variable> style claw
+(assert-true "and-let* #11" (and-let* (#t)
+ 'ok))
+(assert-true "and-let* #12" (and-let* (even?)
+ 'ok))
+(assert-false "and-let* #13" (and-let* (#f)
+ 'ok))
+(assert-true "and-let* #14" (and-let* (even?
+ #t)
+ 'ok))
+(assert-false "and-let* #15" (and-let* (even?
+ #t
+ #f)
+ 'ok))
+
+;; (<expression>) style claw
+(assert-true "and-let* #16" (and-let* (((integer? 1)))
+ 'ok))
+(assert-false "and-let* #17" (and-let* (((integer? #t)))
+ 'ok))
+(assert-true "and-let* #18" (and-let* (((integer? 1))
+ ((integer? 2)))
+ 'ok))
+(assert-false "and-let* #19" (and-let* (((integer? 1))
+ ((integer? 2))
+ ((integer? #t)))
+ 'ok))
+
+;; combined form
+(assert-true "and-let* #20" (and-let* (#t
+ even?
+ ((integer? 1)))
+ 'ok))
+(assert-true "and-let* #21" (and-let* (#t
+ even?
+ ((integer? 1))
+ (foo '(1 2 3))
+ ((list? foo))
+ (bar foo))
+ 'ok))
+(assert-false "and-let* #22" (and-let* (#t
+ even?
+ ((integer? 1))
+ (foo #(1 2 3))
+ ((list? foo))
+ (bar foo))
+ 'ok))
+(assert-false "and-let* #23" (and-let* (#t
+ even?
+ ((integer? 1))
+ (foo '(1 2 3))
+ (bar (car foo))
+ bar
+ ((null? bar)))
+ 'ok))
+
(total-report)
More information about the uim-commit
mailing list