[uim-commit] r1612 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Tue Sep 27 09:22:25 PDT 2005
Author: kzk
Date: 2005-09-27 09:22:21 -0700 (Tue, 27 Sep 2005)
New Revision: 1612
Added:
branches/r5rs/sigscheme/operations-srfi2.c
branches/r5rs/sigscheme/test/test-srfi2.scm
Modified:
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
Log:
* implement "and-let*" described in srfi-2
* sigscheme/operations-srfi2.c
* sigscheme/sigscheme.h
- (ScmOp_SRFI2_and_let_star): new func
* sigscheme/sigscheme.c
- export "and-let*"
* sigscheme/operations.c
- include "operations-srfi2.c" when SCM_USE_SRFI2 is 1
* sigscheme/test/test-srfi2.scm
- test cases for "and-let*"
Added: branches/r5rs/sigscheme/operations-srfi2.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi2.c 2005-09-27 16:11:36 UTC (rev 1611)
+++ branches/r5rs/sigscheme/operations-srfi2.c 2005-09-27 16:22:21 UTC (rev 1612)
@@ -0,0 +1,106 @@
+/*===========================================================================
+ * FileName : operations-srfi2.c
+ * About : AND-LET*: an AND with local bindings, a guarded LET* special form
+ *
+ * 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.
+===========================================================================*/
+
+/*=======================================
+ System Include
+=======================================*/
+
+/*=======================================
+ Local Include
+=======================================*/
+#include "sigscheme.h"
+#include "sigschemeinternal.h"
+
+/*=======================================
+ File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+ File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+
+/*=======================================
+ Function Implementations
+=======================================*/
+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;
+
+ /* sanity check */
+ if CHECK_2_ARGS(args)
+ SigScm_Error("and-let* : syntax error\n");
+
+ /* get bindings and body */
+ bindings = CAR(args);
+ body = CDR(args);
+
+ if (CONSP(bindings)) {
+ for (; !NULLP(bindings); bindings = CDR(bindings)) {
+ binding = CAR(bindings);
+
+ if (NULLP(binding) || NULLP(CDR(binding)))
+ SigScm_ErrorObj("and-let* : invalid binding form : ", binding);
+
+ SCM_SHIFT_RAW_2(var, val, binding);
+ val = EVAL(val, env);
+ if (FALSEP(val))
+ return val;
+
+ env = extend_environment(LIST_1(var), LIST_1(val), env);
+ }
+ } else if (NULLP(bindings)) {
+ env = extend_environment(SCM_NULL,
+ SCM_NULL,
+ env);
+ } else {
+ SigScm_ErrorObj("and-let* : invalid argument ", args);
+ }
+
+ eval_state->env = env;
+
+ return ScmExp_begin(body, eval_state);
+}
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-09-27 16:11:36 UTC (rev 1611)
+++ branches/r5rs/sigscheme/operations.c 2005-09-27 16:22:21 UTC (rev 1612)
@@ -1880,6 +1880,9 @@
#if SCM_USE_SRFI1
#include "operations-srfi1.c"
#endif
+#if SCM_USE_SRFI2
+#include "operations-srfi2.c"
+#endif
#if SCM_USE_SRFI8
#include "operations-srfi8.c"
#endif
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-09-27 16:11:36 UTC (rev 1611)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-09-27 16:22:21 UTC (rev 1612)
@@ -373,6 +373,12 @@
Scm_RegisterFunc1("length+" , ScmOp_SRFI1_lengthplus);
Scm_RegisterFuncEvaledList("concatenate" , ScmOp_SRFI1_concatenate);
#endif
+#if SCM_USE_SRFI2
+ /*=======================================================================
+ SRFI-2 Procedure
+ =======================================================================*/
+ Scm_RegisterSyntaxVariadicTailRec0("and-let*", ScmOp_SRFI2_and_let_star);
+#endif
#if SCM_USE_SRFI8
/*=======================================================================
SRFI-8 Procedure
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-09-27 16:11:36 UTC (rev 1611)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-09-27 16:22:21 UTC (rev 1612)
@@ -56,6 +56,7 @@
/* FIXME: split off to config.h */
#define SCM_USE_EUCJP 1 /* use EUC-JP as internal encoding */
#define SCM_USE_SRFI1 0 /* use SRFI-1 list library procedures written in C */
+#define SCM_USE_SRFI2 1 /* use SRFI-2 and-let* */
#define SCM_USE_SRFI8 1 /* use SRFI-8 receive procedure written in C */
#define SCM_USE_SRFI23 1 /* use SRFI-23 error procedure written in C */
#define SCM_USE_SRFI38 1 /* use SRFI-38 write/ss written in C */
@@ -620,6 +621,9 @@
ScmObj ScmOp_SRFI1_lengthplus(ScmObj lst);
ScmObj ScmOp_SRFI1_concatenate(ScmObj args, ScmObj env);
#endif
+#if SCM_USE_SRFI2
+ScmObj ScmOp_SRFI2_and_let_star(ScmObj args, ScmEvalState *eval_state);
+#endif
#if SCM_USE_SRFI8
/* operations-srfi8.c */
ScmObj ScmOp_SRFI8_receive(ScmObj formals, ScmObj expr, ScmObj body, ScmEvalState *eval_state);
Added: branches/r5rs/sigscheme/test/test-srfi2.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi2.scm 2005-09-27 16:11:36 UTC (rev 1611)
+++ branches/r5rs/sigscheme/test/test-srfi2.scm 2005-09-27 16:22:21 UTC (rev 1612)
@@ -0,0 +1,24 @@
+(load "./test/unittest.scm")
+
+; and-let*
+(assert-true "and-let* test 1" (and-let* () #t))
+(assert-true "and-let* test 2" (and-let* () #t #t))
+(assert-true "and-let* test 3" (and-let* () #t #t #t))
+(assert-false "and-let* test 4" (and-let* () #f))
+(assert-false "and-let* test 5" (and-let* () #t #f))
+(assert-false "and-let* test 6" (and-let* () #t #t #f))
+(assert-false "and-let* test 7" (and-let* ((false (< 2 1)))
+ #t))
+(assert-false "and-let* test 8" (and-let* ((true (< 1 2))
+ (false (< 2 1)))
+ #t))
+(assert-true "and-let* test 9" (and-let* ((one 1)
+ (two (+ one 1))
+ (three (+ two 1)))
+ (= three 3)))
+(assert-false "and-let* test 10" (and-let* ((one 1)
+ (two (+ one 1))
+ (three (+ two 1)))
+ (= three 4)))
+
+(total-report)
More information about the uim-commit
mailing list