1 /*===========================================================================
2 * Filename : module-srfi2.c
3 * About : SRFI-2 AND-LET*: an AND with local bindings, a guarded LET*
4 * special form
5 *
6 * Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
7 * Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
8 * Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
9 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
10 *
11 * All rights reserved.
12 *
13 * Redistribution and use in source and binary forms, with or without
14 * modification, are permitted provided that the following conditions
15 * are met:
16 *
17 * 1. Redistributions of source code must retain the above copyright
18 * notice, this list of conditions and the following disclaimer.
19 * 2. Redistributions in binary form must reproduce the above copyright
20 * notice, this list of conditions and the following disclaimer in the
21 * documentation and/or other materials provided with the distribution.
22 * 3. Neither the name of authors nor the names of its contributors
23 * may be used to endorse or promote products derived from this software
24 * without specific prior written permission.
25 *
26 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
27 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
28 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
29 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
30 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
31 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
32 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
33 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
34 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
35 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
36 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
37 ===========================================================================*/
38
39 #include <config.h>
40
41 #include "sigscheme.h"
42 #include "sigschemeinternal.h"
43
44 /*=======================================
45 File Local Macro Definitions
46 =======================================*/
47
48 /*=======================================
49 File Local Type Definitions
50 =======================================*/
51
52 /*=======================================
53 Variable Definitions
54 =======================================*/
55 #include "functable-srfi2.c"
56
57 /*=======================================
58 File Local Function Declarations
59 =======================================*/
60
61 /*=======================================
62 Function Definitions
63 =======================================*/
64 SCM_EXPORT void
scm_initialize_srfi2(void)65 scm_initialize_srfi2(void)
66 {
67 scm_register_funcs(scm_functable_srfi2);
68 }
69
70 SCM_EXPORT ScmObj
scm_s_srfi2_and_letstar(ScmObj claws,ScmObj body,ScmEvalState * eval_state)71 scm_s_srfi2_and_letstar(ScmObj claws, ScmObj body, ScmEvalState *eval_state)
72 {
73 ScmObj env, claw, var, val, exp;
74 DECLARE_FUNCTION("and-let*", syntax_variadic_tailrec_1);
75
76 env = eval_state->env;
77
78 /*=======================================================================
79 (and-let* <claws> <body>)
80
81 <claws> ::= '() | (cons <claw> <claws>)
82 <claw> ::= (<variable> <expression>) | (<expression>)
83 | <bound-variable>
84 =======================================================================*/
85 val = SCM_TRUE;
86 FOR_EACH (claw, claws) {
87 if (CONSP(claw)) {
88 if (NULLP(CDR(claw))) {
89 /* (<expression>) */
90 exp = CAR(claw);
91 val = EVAL(exp, env);
92 CHECK_VALID_EVALED_VALUE(val);
93 } else if (IDENTIFIERP(CAR(claw))) {
94 /* (<variable> <expression>) */
95 if (!LIST_2_P(claw))
96 goto err;
97 var = CAR(claw);
98 exp = CADR(claw);
99 val = EVAL(exp, env);
100 CHECK_VALID_EVALED_VALUE(val);
101 env = scm_extend_environment(LIST_1(var), LIST_1(val), env);
102 } else {
103 goto err;
104 }
105 } else if (IDENTIFIERP(claw)) {
106 /* <bound-variable> */
107 val = EVAL(claw, env);
108 CHECK_VALID_EVALED_VALUE(val);
109 } else {
110 goto err;
111 }
112 if (FALSEP(val)) {
113 eval_state->ret_type = SCM_VALTYPE_AS_IS;
114 return SCM_FALSE;
115 }
116 }
117 if (!NULLP(claws))
118 goto err;
119
120 eval_state->env = env;
121
122 /* SRFI-2 Formal (Denotational) Semantics:
123 * eval[ (AND-LET* (CLAW) ), env] = eval_claw[ CLAW, env ]
124 * eval[ (AND-LET* () ), env] = #t */
125 if (NULLP(body)) {
126 eval_state->ret_type = SCM_VALTYPE_AS_IS;
127 return val;
128 } else {
129 return scm_s_body(body, eval_state);
130 }
131
132 err:
133 ERR_OBJ("invalid claws form", claws);
134 /* NOTREACHED */
135 return SCM_FALSE;
136 }
137