[uim-commit] r1233 - in branches/r5rs/sigscheme: . test
kzk at freedesktop.org
kzk at freedesktop.org
Fri Aug 19 01:23:55 PDT 2005
Author: kzk
Date: 2005-08-19 01:22:49 -0700 (Fri, 19 Aug 2005)
New Revision: 1233
Added:
branches/r5rs/sigscheme/operations-srfi8.c
branches/r5rs/sigscheme/test/test-srfi8.scm
Modified:
branches/r5rs/sigscheme/operations.c
branches/r5rs/sigscheme/sigscheme.c
branches/r5rs/sigscheme/sigscheme.h
branches/r5rs/sigscheme/test/gauche-primsyn.scm
Log:
* implement "receive" defined in SRFI-8. This is done by Jun Inoue
<jun.lambda at gmail.com>. Thank you!
* sigscheme/sigscheme.c
- (SigScm_Initialize): export "receive"
* sigscheme/operations-srfi8.c
- new file
* sigscheme/sigscheme.h
- (USE_SRFI8): new preprocessor symbol
* sigscheme/operations.c
- include operations-srfi8.c when USE_SRFI8 is defined as 1
* test/test-srfi8.scm
- new file
* test/gauche-primsyn.scm
- enable "receive" test case
Added: branches/r5rs/sigscheme/operations-srfi8.c
===================================================================
--- branches/r5rs/sigscheme/operations-srfi8.c 2005-08-19 04:45:56 UTC (rev 1232)
+++ branches/r5rs/sigscheme/operations-srfi8.c 2005-08-19 08:22:49 UTC (rev 1233)
@@ -0,0 +1,104 @@
+/*===========================================================================
+ * FileName : operations-srfi8.c
+ * About : srfi8 receive syntax
+ *
+ * Copyright (C) 2005 by Jun Inoue
+ *
+ * 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"
+
+/*=======================================
+ File Local Struct Declarations
+=======================================*/
+
+/*=======================================
+ File Local Macro Declarations
+=======================================*/
+
+/*=======================================
+ Variable Declarations
+=======================================*/
+
+/*=======================================
+ File Local Function Declarations
+=======================================*/
+
+/*=======================================
+ Function Implementations
+=======================================*/
+
+/*=============================================================================
+ SRFI8 : Receive
+=============================================================================*/
+ScmObj ScmOp_SRFI_8_receive(ScmObj args, ScmObj *envp, int *tail_flag)
+{
+ /*
+ * (receive <formals> <expression> <body>)
+ */
+ ScmObj env = *envp;
+ ScmObj formals = SCM_NIL;
+ ScmObj expr = SCM_NIL;
+ ScmObj body = SCM_NIL;
+ ScmObj actuals = SCM_NIL;
+ ScmObj closure = SCM_NIL;
+
+ /* sanity check */
+ if (CHECK_3_ARGS(args))
+ SigScm_ErrorObj("receive: bad argument list: ", args);
+
+ /* set tail_flag */
+ (*tail_flag) = 1;
+
+ formals = SCM_CAR(args);
+ expr = SCM_CADR(args);
+ body = SCM_CDDR(args);
+
+ /* TODO: Check: do we have to extend the environment first? The SRFI-8
+ * document contradicts itself on this part. */
+ actuals = ScmOp_eval(expr, env);
+
+ if (SCM_VALUEPACKETP(actuals))
+ actuals = SCM_VALUEPACKET_VALUES(actuals);
+ else
+ actuals = Scm_NewCons(actuals, SCM_NIL);
+
+ closure = Scm_NewClosure(Scm_NewCons(formals, body), env);
+
+ /* set new env */
+ (*envp) = env;
+
+ return Scm_NewCons(closure, actuals);
+}
Modified: branches/r5rs/sigscheme/operations.c
===================================================================
--- branches/r5rs/sigscheme/operations.c 2005-08-19 04:45:56 UTC (rev 1232)
+++ branches/r5rs/sigscheme/operations.c 2005-08-19 08:22:49 UTC (rev 1233)
@@ -1990,3 +1990,6 @@
#if USE_SRFI1
#include "operations-srfi1.c"
#endif
+#if USE_SRFI8
+#include "operations-srfi8.c"
+#endif
Modified: branches/r5rs/sigscheme/sigscheme.c
===================================================================
--- branches/r5rs/sigscheme/sigscheme.c 2005-08-19 04:45:56 UTC (rev 1232)
+++ branches/r5rs/sigscheme/sigscheme.c 2005-08-19 08:22:49 UTC (rev 1233)
@@ -305,6 +305,9 @@
Scm_RegisterFuncL("circular-list" , ScmOp_SRFI_1_circular_list);
Scm_RegisterFuncL("iota" , ScmOp_SRFI_1_iota);
#endif
+#if USE_SRFI8
+ Scm_RegisterFuncR("receive" , ScmOp_SRFI_8_receive);
+#endif
stack_start_pointer = NULL;
}
Modified: branches/r5rs/sigscheme/sigscheme.h
===================================================================
--- branches/r5rs/sigscheme/sigscheme.h 2005-08-19 04:45:56 UTC (rev 1232)
+++ branches/r5rs/sigscheme/sigscheme.h 2005-08-19 08:22:49 UTC (rev 1233)
@@ -75,6 +75,7 @@
#define DEBUG_GC 0
#define USE_EUCJP 1
#define USE_SRFI1 0
+#define USE_SRFI8 1
#define CHECK_1_ARG(arg) \
(SCM_NULLP(arg))
@@ -355,6 +356,9 @@
ScmObj ScmOp_SRFI_1_circular_list(ScmObj list, ScmObj env);
ScmObj ScmOp_SRFI_1_iota(ScmObj args, ScmObj env);
#endif
+#if USE_SRFI8
+ScmObj ScmOp_SRFI_8_receive(ScmObj args, ScmObj *envp, int *tail_flag);
+#endif
#ifdef __cplusplus
}
Modified: branches/r5rs/sigscheme/test/gauche-primsyn.scm
===================================================================
--- branches/r5rs/sigscheme/test/gauche-primsyn.scm 2005-08-19 04:45:56 UTC (rev 1232)
+++ branches/r5rs/sigscheme/test/gauche-primsyn.scm 2005-08-19 08:22:49 UTC (rev 1233)
@@ -127,14 +127,14 @@
;;----------------------------------------------------------------
;(test-section "multiple values")
-;(test "receive" '(1 2 3)
-; (lambda () (receive (a b c) (values 1 2 3) (list a b c))))
-;(test "receive" '(1 2 3)
-; (lambda () (receive (a . r) (values 1 2 3) (cons a r))))
-;(test "receive" '(1 2 3)
-; (lambda () (receive x (values 1 2 3) x)))
-;(test "receive" 1
-; (lambda () (receive (a) 1 a)))
+(test "receive" '(1 2 3)
+ (lambda () (receive (a b c) (values 1 2 3) (list a b c))))
+(test "receive" '(1 2 3)
+ (lambda () (receive (a . r) (values 1 2 3) (cons a r))))
+(test "receive" '(1 2 3)
+ (lambda () (receive x (values 1 2 3) x)))
+(test "receive" 1
+ (lambda () (receive (a) 1 a)))
(test "call-with-values" '(1 2 3)
(lambda () (call-with-values (lambda () (values 1 2 3)) list)))
(test "call-with-values" '()
Added: branches/r5rs/sigscheme/test/test-srfi8.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-srfi8.scm 2005-08-19 04:45:56 UTC (rev 1232)
+++ branches/r5rs/sigscheme/test/test-srfi8.scm 2005-08-19 08:22:49 UTC (rev 1233)
@@ -0,0 +1,8 @@
+(load "test/unittest.scm")
+
+(assert "receive test1"
+ (receive (a b c)
+ (values #f #f #t)
+ (and (not a) (not b) c)))
+
+(total-report)
More information about the uim-commit
mailing list