1
/*===========================================================================
3
* About : R5RS syntaxes
5
* Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6
* Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7
* Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8
* Copyright (c) 2007 SigScheme Project <uim AT freedesktop.org>
10
* All rights reserved.
12
* Redistribution and use in source and binary forms, with or without
13
* modification, are permitted provided that the following conditions
16
* 1. Redistributions of source code must retain the above copyright
17
* notice, this list of conditions and the following disclaimer.
18
* 2. Redistributions in binary form must reproduce the above copyright
19
* notice, this list of conditions and the following disclaimer in the
20
* documentation and/or other materials provided with the distribution.
21
* 3. Neither the name of authors nor the names of its contributors
22
* may be used to endorse or promote products derived from this software
23
* without specific prior written permission.
25
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26
* IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27
* THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28
* PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29
* CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32
* OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33
* WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34
* OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35
* ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36
===========================================================================*/
40
#include "sigscheme.h"
41
#include "sigschemeinternal.h"
43
/*=======================================
44
File Local Macro Definitions
45
=======================================*/
46
#define ERRMSG_CLAUSE_REQUIRED "at least 1 clause required"
47
#define ERRMSG_EXPRESSION_REQUIRED "at least 1 expression required"
48
#define ERRMSG_INVALID_BINDINGS "invalid bindings form"
49
#define ERRMSG_INVALID_BINDING "invalid binding form"
50
#define ERRMSG_SYNTAX_AS_VALUE "syntactic keyword is passed as value"
51
#define ERRMSG_DUPLICATE_VARNAME "duplicate variable name"
52
#define ERRMSG_BAD_DEFINE_FORM "bad definition form"
54
#if SCM_USE_INTERNAL_DEFINITIONS
55
#define ERRMSG_BAD_DEFINE_PLACEMENT "definitions are valid only at toplevel" \
56
" or beginning of a binding construct"
58
#define ERRMSG_BAD_DEFINE_PLACEMENT "internal definitions feature is disabled"
61
/* FIXME: temporary hack */
62
#if SCM_STRICT_TOPLEVEL_DEFINITIONS
63
#define FORBID_TOPLEVEL_DEFINITIONS(env) \
64
(EQ((env), SCM_INTERACTION_ENV) ? SCM_INTERACTION_ENV_INDEFINABLE : (env))
66
#define FORBID_TOPLEVEL_DEFINITIONS(env) (env)
69
#if SCM_USE_HYGIENIC_MACRO
70
#define CHECK_VALID_BINDEE(permitted_type, bindee) \
72
if (permitted_type == ScmFirstClassObj) \
73
CHECK_VALID_EVALED_VALUE(bindee); \
74
else if (permitted_type == ScmMacro) \
75
SCM_ASSERT(HMACROP(bindee)); \
78
} while (/* CONSTCOND */ 0)
80
#define CHECK_VALID_BINDEE(permitted_type, bindee) \
82
if (permitted_type == ScmFirstClassObj) \
83
CHECK_VALID_EVALED_VALUE(bindee); \
86
} while (/* CONSTCOND */ 0)
89
/*=======================================
90
File Local Type Definitions
91
=======================================*/
93
/*=======================================
95
=======================================*/
96
#include "functable-r5rs-syntax.c"
98
SCM_DEFINE_EXPORTED_VARS(syntax);
100
SCM_GLOBAL_VARS_BEGIN(static_syntax);
102
static ScmObj l_sym_else, l_sym_yields, l_sym_define;
103
#if SCM_USE_INTERNAL_DEFINITIONS
104
static ScmObj l_sym_begin, l_syn_lambda;
105
#endif /* SCM_USE_INTERNAL_DEFINITIONS */
107
SCM_GLOBAL_VARS_END(static_syntax);
108
#define l_sym_else SCM_GLOBAL_VAR(static_syntax, l_sym_else)
109
#define l_sym_yields SCM_GLOBAL_VAR(static_syntax, l_sym_yields)
110
#define l_sym_define SCM_GLOBAL_VAR(static_syntax, l_sym_define)
111
#define l_sym_begin SCM_GLOBAL_VAR(static_syntax, l_sym_begin)
112
#define l_syn_lambda SCM_GLOBAL_VAR(static_syntax, l_syn_lambda)
113
SCM_DEFINE_STATIC_VARS(static_syntax);
115
/*=======================================
116
File Local Function Declarations
117
=======================================*/
118
#if SCM_USE_INTERNAL_DEFINITIONS
119
static ScmObj filter_definitions(ScmObj body, ScmObj *formals, ScmObj *actuals,
123
/*=======================================
125
=======================================*/
127
scm_init_syntax(void)
129
SCM_GLOBAL_VARS_INIT(syntax);
130
SCM_GLOBAL_VARS_INIT(static_syntax);
132
scm_register_funcs(scm_functable_r5rs_syntax);
134
scm_sym_quote = scm_intern("quote");
135
scm_sym_quasiquote = scm_intern("quasiquote");
136
scm_sym_unquote = scm_intern("unquote");
137
scm_sym_unquote_splicing = scm_intern("unquote-splicing");
138
scm_sym_ellipsis = scm_intern("...");
140
l_sym_else = scm_intern("else");
141
l_sym_yields = scm_intern("=>");
142
l_sym_define = scm_intern("define");
143
#if SCM_USE_INTERNAL_DEFINITIONS
144
l_sym_begin = scm_intern("begin");
145
scm_gc_protect_with_init(&l_syn_lambda,
146
scm_symbol_value(scm_intern("lambda"),
147
SCM_INTERACTION_ENV));
151
/*=======================================
152
R5RS : 4.1 Primitive expression types
153
=======================================*/
154
/*===========================================================================
155
R5RS : 4.1 Primitive expression types : 4.1.2 Literal expressions
156
===========================================================================*/
158
scm_s_quote(ScmObj datum, ScmObj env)
160
DECLARE_FUNCTION("quote", syntax_fixed_1);
162
#if SCM_USE_HYGIENIC_MACRO
163
/* Passing objects that contain a circular list to SCM_UNWRAP_SYNTAX()
164
* causes infinite loop. For instance, (error circular-list) raises it via
165
* the error object which contains the circular list.
166
* -- YamaKen 2006-10-02 */
171
return SCM_UNWRAP_SYNTAX(datum);
174
/*===========================================================================
175
R5RS : 4.1 Primitive expression types : 4.1.4 Procedures
176
===========================================================================*/
178
scm_s_lambda(ScmObj formals, ScmObj body, ScmObj env)
180
DECLARE_FUNCTION("lambda", syntax_variadic_1);
182
#if SCM_STRICT_ARGCHECK
183
if (SCM_LISTLEN_ERRORP(scm_validate_formals(formals)))
184
ERR_OBJ("bad formals", formals);
186
/* Keeping variable name unique is user's responsibility. R5RS: "It is an
187
* error for a <variable> to appear more than once in <formals>.". */
189
/* Crashless no-validation:
190
* Regard any non-list object as symbol. Since the lookup operation search
191
* for a variable by EQ, this is safe although loosely allows
192
* R5RS-incompatible code. */
195
/* Internal definitions-only body such as ((define foo bar)) is
196
* invalid. But since checking it here is inefficient, it is deferred to
197
* scm_s_body() on being called. */
199
ERR_OBJ(ERRMSG_EXPRESSION_REQUIRED, body);
201
return MAKE_CLOSURE(CONS(formals, body), env);
204
/*===========================================================================
205
R5RS : 4.1 Primitive expression types : 4.1.5 Conditionals
206
===========================================================================*/
208
scm_s_if(ScmObj test, ScmObj conseq, ScmObj rest, ScmEvalState *eval_state)
211
DECLARE_FUNCTION("if", syntax_variadic_tailrec_2);
213
env = eval_state->env;
215
/*=======================================================================
216
(if <test> <consequent>)
217
(if <test> <consequent> <alternate>)
218
=======================================================================*/
220
test = EVAL(test, env);
221
CHECK_VALID_EVALED_VALUE(test);
223
#if SCM_STRICT_ARGCHECK
225
ASSERT_NO_MORE_ARG(rest);
229
#if SCM_COMPAT_SIOD_BUGS
230
alt = (CONSP(rest)) ? CAR(rest) : SCM_NULL;
232
alt = (CONSP(rest)) ? CAR(rest) : SCM_UNDEF;
234
#if SCM_STRICT_ARGCHECK
236
ASSERT_NO_MORE_ARG(rest);
242
/*===========================================================================
243
R5RS : 4.1 Primitive expression types : 4.1.6 Assignments
244
===========================================================================*/
246
scm_s_setx(ScmObj sym, ScmObj exp, ScmObj env)
249
ScmRef locally_bound;
250
DECLARE_FUNCTION("set!", syntax_fixed_2);
254
evaled = EVAL(exp, env);
255
CHECK_VALID_EVALED_VALUE(evaled);
256
locally_bound = scm_lookup_environment(sym, env);
257
if (locally_bound != SCM_INVALID_REF) {
258
SET(locally_bound, evaled);
260
if (!SCM_SYMBOL_BOUNDP(sym))
261
ERR_OBJ("unbound variable", sym);
263
SCM_SYMBOL_SET_VCELL(sym, evaled);
274
/*=======================================
275
R5RS : 4.2 Derived expression types
276
=======================================*/
277
/*===========================================================================
278
R5RS : 4.2 Derived expression types : 4.2.1 Conditionals
279
===========================================================================*/
280
/* body of 'cond' and 'guard' of SRFI-34 */
282
scm_s_cond_internal(ScmObj clauses, ScmEvalState *eval_state)
284
ScmObj env, clause, test, exps, proc;
285
DECLARE_INTERNAL_FUNCTION("cond" /* , syntax_variadic_tailrec_0 */);
287
env = eval_state->env;
288
#if SCM_STRICT_TOPLEVEL_DEFINITIONS
289
eval_state->nest = SCM_NEST_COMMAND;
293
* (cond <cond clause>+)
294
* (cond <cond clause>* (else <sequence>))
296
* <cond clause> --> (<test> <sequence>)
298
* | (<test> => <recipient>)
299
* <recipient> --> <expression>
300
* <test> --> <expression>
301
* <sequence> --> <command>* <expression>
302
* <command> --> <expression>
305
if (NO_MORE_ARG(clauses))
306
ERR(ERRMSG_CLAUSE_REQUIRED);
308
/* looping in each clause */
309
FOR_EACH (clause, clauses) {
311
ERR_OBJ("bad clause", clause);
317
test = SCM_UNWRAP_SYNTAX(test); /* FIXME: needed? */
319
if (EQ(test, l_sym_else)) {
320
ASSERT_NO_MORE_ARG(clauses);
321
return scm_s_begin(exps, eval_state);
324
test = EVAL(test, env);
325
CHECK_VALID_EVALED_VALUE(test);
328
* if the selected <clause> contains only the <test> and no
329
* <expression>s, then the value of the <test> is returned as the
333
eval_state->ret_type = SCM_VALTYPE_AS_IS;
338
* If the selected <clause> uses the => alternate form, then the
339
* <expression> is evaluated. Its value must be a procedure that
340
* accepts one argument; this procedure is then called on the value
341
* of the <test> and the value returned by this procedure is
342
* returned by the cond expression.
344
if (EQ(l_sym_yields, CAR(exps)) && LIST_2_P(exps)) {
345
proc = EVAL(CADR(exps), env);
346
if (!PROCEDUREP(proc))
347
ERR_OBJ("exp after => must be a procedure but got", proc);
350
* R5RS: 3.5 Proper tail recursion
352
* If a `cond' expression is in a tail context, and has a
353
* clause of the form `(<expression1> => <expression2>)' then
354
* the (implied) call to the procedure that results from the
355
* evaluation of <expression2> is in a tail
356
* context. <expression2> itself is not in a tail context.
358
return LIST_2(proc, LIST_2(SYM_QUOTE, test));
361
return scm_s_begin(exps, eval_state);
364
ASSERT_NO_MORE_ARG(clauses);
367
* To distinguish unmatched status from SCM_UNDEF from a clause, pure
368
* internal value SCM_INVALID is returned. Don't pass it to Scheme world.
370
eval_state->ret_type = SCM_VALTYPE_AS_IS;
375
scm_s_cond(ScmObj clauses, ScmEvalState *eval_state)
378
DECLARE_FUNCTION("cond", syntax_variadic_tailrec_0);
380
ret = scm_s_cond_internal(clauses, eval_state);
381
return (VALIDP(ret)) ? ret : SCM_UNDEF;
385
scm_s_case(ScmObj key, ScmObj clauses, ScmEvalState *eval_state)
387
ScmObj clause, test, exps;
388
DECLARE_FUNCTION("case", syntax_variadic_tailrec_1);
398
* <case clause> --> ((<datum>*) <sequence>)
399
* <sequence> --> <command>* <expression>
400
* <command> --> <expression>
401
* <Datum> is what the read procedure (see section 6.6.2 Input)
402
* successfully parses.
405
if (NO_MORE_ARG(clauses))
406
ERR(ERRMSG_CLAUSE_REQUIRED);
408
key = EVAL(key, eval_state->env);
409
CHECK_VALID_EVALED_VALUE(key);
411
FOR_EACH (clause, clauses) {
413
ERR_OBJ("bad clause", clause);
418
test = SCM_UNWRAP_SYNTAX(test);
419
if (EQ(test, l_sym_else))
420
ASSERT_NO_MORE_ARG(clauses);
422
test = scm_p_memv(key, test);
425
#if SCM_STRICT_TOPLEVEL_DEFINITIONS
426
eval_state->nest = SCM_NEST_COMMAND;
428
return scm_s_begin(exps, eval_state);
431
ASSERT_NO_MORE_ARG(clauses);
437
scm_s_and(ScmObj args, ScmEvalState *eval_state)
439
ScmObj expr, val, env;
440
DECLARE_FUNCTION("and", syntax_variadic_tailrec_0);
442
if (NO_MORE_ARG(args)) {
443
eval_state->ret_type = SCM_VALTYPE_AS_IS;
446
env = FORBID_TOPLEVEL_DEFINITIONS(eval_state->env);
448
FOR_EACH_BUTLAST (expr, args) {
449
val = EVAL(expr, env);
450
CHECK_VALID_EVALED_VALUE(val);
452
ASSERT_PROPER_ARG_LIST(args);
453
eval_state->ret_type = SCM_VALTYPE_AS_IS;
457
ASSERT_NO_MORE_ARG(args);
463
scm_s_or(ScmObj args, ScmEvalState *eval_state)
465
ScmObj expr, val, env;
466
DECLARE_FUNCTION("or", syntax_variadic_tailrec_0);
468
if (NO_MORE_ARG(args)) {
469
eval_state->ret_type = SCM_VALTYPE_AS_IS;
472
env = FORBID_TOPLEVEL_DEFINITIONS(eval_state->env);
474
FOR_EACH_BUTLAST (expr, args) {
475
val = EVAL(expr, env);
476
CHECK_VALID_EVALED_VALUE(val);
478
ASSERT_PROPER_ARG_LIST(args);
479
eval_state->ret_type = SCM_VALTYPE_AS_IS;
483
ASSERT_NO_MORE_ARG(args);
488
/*===========================================================================
489
R5RS : 4.2 Derived expression types : 4.2.2 Binding constructs
490
===========================================================================*/
492
scm_s_let(ScmObj bindings, ScmObj body, ScmEvalState *eval_state)
494
DECLARE_FUNCTION("let", syntax_variadic_tailrec_1);
496
return scm_s_let_internal(ScmFirstClassObj, bindings, body, eval_state);
500
scm_s_let_internal(enum ScmObjType permitted, ScmObj bindings, ScmObj body,
501
ScmEvalState *eval_state)
503
ScmObj env, named_let_sym, proc, binding;
504
ScmObj formals, var, actuals, val, exp;
506
DECLARE_INTERNAL_FUNCTION("let" /* , syntax_variadic_tailrec_1 */);
508
env = eval_state->env;
509
named_let_sym = SCM_FALSE;
511
/*=======================================================================
514
(let (<binding spec>*) <body>)
518
(let <variable> (<binding spec>*) <body>)
520
<binding spec> --> (<variable> <expression>)
521
<body> --> <definition>* <sequence>
522
<definition> --> (define <variable> <expression>)
523
| (define (<variable> <def formals>) <body>)
524
| (begin <definition>*)
525
<sequence> --> <command>* <expression>
526
<command> --> <expression>
527
=======================================================================*/
530
if (IDENTIFIERP(bindings)) {
531
named_let_sym = bindings;
534
ERR("invalid named let form");
535
bindings = POP(body);
538
formals = actuals = SCM_NULL;
539
SCM_QUEUE_POINT_TO(varq, formals);
540
SCM_QUEUE_POINT_TO(valq, actuals);
541
FOR_EACH (binding, bindings) {
542
#if SCM_COMPAT_SIOD_BUGS
543
/* temporary solution. the inefficiency is not a problem */
544
if (LIST_1_P(binding))
545
binding = LIST_2(CAR(binding), SCM_FALSE);
548
if (!LIST_2_P(binding) || !IDENTIFIERP(var = CAR(binding)))
549
ERR_OBJ(ERRMSG_INVALID_BINDING, binding);
550
#if SCM_STRICT_ARGCHECK
551
/* Optional check. Keeping variable name unique is user's
552
* responsibility. R5RS: "It is an error for a <variable> to appear
553
* more than once in the list of variables being bound." */
554
if (TRUEP(scm_p_memq(var, formals)))
555
ERR_OBJ(ERRMSG_DUPLICATE_VARNAME, var);
558
val = EVAL(exp, env);
559
CHECK_VALID_BINDEE(permitted, val);
561
SCM_QUEUE_ADD(varq, var);
562
SCM_QUEUE_ADD(valq, val);
564
if (!NULLP(bindings))
565
ERR_OBJ(ERRMSG_INVALID_BINDINGS, bindings);
567
env = scm_extend_environment(formals, actuals, env);
570
if (IDENTIFIERP(named_let_sym)) {
571
proc = MAKE_CLOSURE(CONS(formals, body), env);
572
env = scm_add_environment(named_let_sym, proc, env);
573
SCM_CLOSURE_SET_ENV(proc, env);
576
eval_state->env = env;
577
return scm_s_body(body, eval_state);
581
scm_s_letstar(ScmObj bindings, ScmObj body, ScmEvalState *eval_state)
583
ScmObj env, var, val, exp, binding;
584
DECLARE_FUNCTION("let*", syntax_variadic_tailrec_1);
586
env = eval_state->env;
588
/*=======================================================================
589
(let* (<binding spec>*) <body>)
591
<binding spec> --> (<variable> <expression>)
592
<body> --> <definition>* <sequence>
593
<definition> --> (define <variable> <expression>)
594
| (define (<variable> <def formals>) <body>)
595
| (begin <definition>*)
596
<sequence> --> <command>* <expression>
597
<command> --> <expression>
598
=======================================================================*/
600
FOR_EACH (binding, bindings) {
601
#if SCM_COMPAT_SIOD_BUGS
602
/* temporary solution. the inefficiency is not a problem */
603
if (LIST_1_P(binding))
604
binding = LIST_2(CAR(binding), SCM_FALSE);
607
if (!LIST_2_P(binding) || !IDENTIFIERP(var = CAR(binding)))
608
ERR_OBJ(ERRMSG_INVALID_BINDING, binding);
611
val = EVAL(exp, env);
612
CHECK_VALID_EVALED_VALUE(val);
614
/* extend env for each variable */
615
env = scm_extend_environment(LIST_1(var), LIST_1(val), env);
617
if (!NULLP(bindings))
618
ERR_OBJ(ERRMSG_INVALID_BINDINGS, bindings);
620
eval_state->env = env;
621
return scm_s_body(body, eval_state);
625
scm_s_letrec(ScmObj bindings, ScmObj body, ScmEvalState *eval_state)
627
DECLARE_FUNCTION("letrec", syntax_variadic_tailrec_1);
629
return scm_s_letrec_internal(ScmFirstClassObj, bindings, body, eval_state);
633
scm_s_letrec_internal(enum ScmObjType permitted, ScmObj bindings, ScmObj body,
634
ScmEvalState *eval_state)
636
ScmObj binding, formals, actuals, var, val, exp, env;
637
DECLARE_INTERNAL_FUNCTION("letrec" /* , syntax_variadic_tailrec_1 */);
639
/*=======================================================================
640
(letrec (<binding spec>*) <body>)
642
<binding spec> --> (<variable> <expression>)
643
<body> --> <definition>* <sequence>
644
<definition> --> (define <variable> <expression>)
645
| (define (<variable> <def formals>) <body>)
646
| (begin <definition>*)
647
<sequence> --> <command>* <expression>
648
<command> --> <expression>
649
=======================================================================*/
651
/* extend env by placeholder frame for subsequent lambda evaluations */
652
env = scm_extend_environment(SCM_NULL, SCM_NULL, eval_state->env);
654
formals = actuals = SCM_NULL;
655
FOR_EACH (binding, bindings) {
656
if (!LIST_2_P(binding) || !IDENTIFIERP(var = CAR(binding)))
657
ERR_OBJ(ERRMSG_INVALID_BINDING, binding);
658
#if SCM_STRICT_ARGCHECK
659
/* Optional check. Keeping variable name unique is user's
660
* responsibility. R5RS: "It is an error for a <variable> to appear
661
* more than once in the list of variables being bound." */
662
if (TRUEP(scm_p_memq(var, formals)))
663
ERR_OBJ(ERRMSG_DUPLICATE_VARNAME, var);
666
val = EVAL(exp, env);
667
CHECK_VALID_BINDEE(permitted, val);
669
/* construct formals and actuals list: any <init> must not refer a
670
* <variable> at this time */
671
formals = CONS(var, formals);
672
actuals = CONS(val, actuals);
674
if (!NULLP(bindings))
675
ERR_OBJ(ERRMSG_INVALID_BINDINGS, bindings);
677
/* fill the placeholder frame */
678
eval_state->env = scm_replace_environment(formals, actuals, env);
680
return scm_s_body(body, eval_state);
684
* Valid placement for definitions
686
* Definitions on SigScheme is strictly conformed to the three rule specified
687
* in R5RS (see below), when SCM_USE_INTERNAL_DEFINITIONS is enabled. All
688
* conditions that are not specified by the rules cause syntax error.
692
* Definitions are valid in some, but not all, contexts where expressions are
693
* allowed. They are valid only at the top level of a <program> and at the
694
* beginning of a <body>.
696
* 5.2.2 Internal definitions
698
* Definitions may occur at the beginning of a <body> (that is, the body of a
699
* lambda, let, let*, letrec, let-syntax, or letrec-syntax expression or that
700
* of a definition of an appropriate form).
702
* Wherever an internal definition may occur (begin <definition1> ...) is
703
* equivalent to the sequence of definitions that form the body of the begin.
705
* 7.1.6 Programs and definitions
707
* <definition> --> (define <variable> <expression>)
708
* | (define (<variable> <def formals>) <body>)
709
* | (begin <definition>*)
712
#if SCM_USE_INTERNAL_DEFINITIONS
714
filter_definitions(ScmObj body, ScmObj *formals, ScmObj *actuals,
717
ScmObj exp, var, sym, begin_rest, lambda_formals, lambda_body;
718
DECLARE_INTERNAL_FUNCTION("(body)");
720
for (; CONSP(body); POP(body)) {
725
if (EQ(sym, l_sym_begin)) {
726
begin_rest = filter_definitions(exp, formals, actuals, def_expq);
727
if (!NULLP(begin_rest)) {
728
/* no definitions found */
729
if (begin_rest == exp)
732
ERR_OBJ("definitions and expressions intermixed", CAR(body));
734
/* '(begin)' is a valid R5RS definition form */
735
} else if (EQ(sym, l_sym_define)) {
736
var = MUST_POP_ARG(exp);
737
if (IDENTIFIERP(var)) {
738
/* (define <variable> <expression>) */
740
ERR_OBJ(ERRMSG_BAD_DEFINE_FORM, CAR(body));
742
} else if (CONSP(var)) {
743
/* (define (<variable> . <formals>) <body>) */
745
lambda_formals = CDR(var);
750
exp = CONS(l_syn_lambda, CONS(lambda_formals, lambda_body));
752
ERR_OBJ(ERRMSG_BAD_DEFINE_FORM, CAR(body));
754
*formals = CONS(var, *formals);
755
*actuals = CONS(SCM_UNBOUND, *actuals);
756
SCM_QUEUE_ADD(*def_expq, exp);
765
/* <body> part of let, let*, letrec and lambda. This function performs strict
766
* form validation for internal definitions as specified in R5RS ("5.2.2
767
* Internal definitions" and "7.1.6 Programs and definitions"). */
768
/* TODO: Introduce compilation phase and reorganize into compile-time syntax
771
scm_s_body(ScmObj body, ScmEvalState *eval_state)
774
ScmObj env, formals, actuals, def_exps, exp, val;
775
DECLARE_INTERNAL_FUNCTION("(body)" /* , syntax_variadic_tailrec_0 */);
778
/* collect internal definitions */
779
def_exps = formals = actuals = SCM_NULL;
780
SCM_QUEUE_POINT_TO(def_expq, def_exps);
781
body = filter_definitions(body, &formals, &actuals, &def_expq);
783
if (!NULLP(def_exps)) {
784
/* extend env with the unbound variables */
785
env = scm_extend_environment(formals, actuals, eval_state->env);
787
/* eval the definitions and fill the variables with the results as
790
FOR_EACH (exp, def_exps) {
791
val = EVAL(exp, env);
792
CHECK_VALID_EVALED_VALUE(val);
793
actuals = CONS(val, actuals);
795
eval_state->env = scm_update_environment(actuals, env);
798
/* eval rest of the body */
799
return scm_s_begin(body, eval_state);
801
#endif /* SCM_USE_INTERNAL_DEFINITIONS */
803
/*===========================================================================
804
R5RS : 4.2 Derived expression types : 4.2.3 Sequencing
805
===========================================================================*/
807
scm_s_begin(ScmObj args, ScmEvalState *eval_state)
810
DECLARE_FUNCTION("begin", syntax_variadic_tailrec_0);
812
if (SCM_DEFINABLE_TOPLEVELP(eval_state)) {
815
ASSERT_NO_MORE_ARG(args);
816
eval_state->ret_type = SCM_VALTYPE_AS_IS;
819
env = eval_state->env;
820
#if SCM_STRICT_TOPLEVEL_DEFINITIONS
821
eval_state->nest = SCM_NEST_RETTYPE_BEGIN;
825
ERR(ERRMSG_EXPRESSION_REQUIRED);
826
env = FORBID_TOPLEVEL_DEFINITIONS(eval_state->env);
829
FOR_EACH_BUTLAST (expr, args) {
830
expr = EVAL(expr, env);
831
CHECK_VALID_EVALED_VALUE(expr);
833
ASSERT_NO_MORE_ARG(args);
838
/*===========================================================================
839
R5RS : 4.2 Derived expression types : 4.2.4 Iteration
840
===========================================================================*/
842
scm_s_do(ScmObj bindings, ScmObj test_exps, ScmObj commands,
843
ScmEvalState *eval_state)
846
ScmObj env, orig_env, rest, rest_commands, val, termp;
847
ScmObj formals, actuals, steps;
848
ScmObj binding, var, init, step;
849
ScmObj test, exps, command;
850
DECLARE_FUNCTION("do", syntax_variadic_tailrec_2);
852
orig_env = eval_state->env;
855
* (do ((<variable1> <init1> <step1>)
856
* (<variable2> <init2> <step2>)
858
* (<test> <expression> ...)
862
/* extract bindings ((<variable> <init> <step>) ...) */
863
env = FORBID_TOPLEVEL_DEFINITIONS(orig_env);
864
formals = actuals = steps = SCM_NULL;
865
SCM_QUEUE_POINT_TO(stepq, steps);
867
FOR_EACH (binding, rest) {
872
#if SCM_STRICT_ARGCHECK
873
/* Optional check. Keeping variable name unique is user's
874
* responsibility. R5RS: "It is an error for a <variable> to appear
875
* more than once in the list of `do' variables.". */
876
if (TRUEP(scm_p_memq(var, formals)))
877
ERR_OBJ(ERRMSG_DUPLICATE_VARNAME, var);
884
step = (CONSP(binding)) ? POP(binding) : var;
888
init = EVAL(init, env);
889
CHECK_VALID_EVALED_VALUE(init);
890
formals = CONS(var, formals);
891
actuals = CONS(init, actuals);
892
SCM_QUEUE_ADD(stepq, step);
897
/* (<test> <expression> ...) */
898
if (!CONSP(test_exps))
899
ERR_OBJ("invalid test form", test_exps);
900
test = CAR(test_exps);
901
exps = CDR(test_exps);
903
/* iteration phase */
904
rest_commands = commands;
905
/* extend env by <init>s */
906
env = scm_extend_environment(formals, actuals, orig_env);
907
while (termp = EVAL(test, env), FALSEP(termp)) {
908
rest_commands = commands;
909
FOR_EACH (command, rest_commands)
911
ASSERT_NO_MORE_ARG(rest_commands);
913
/* Update variables by <step>s: <step>s evaluation must be isolated
914
* from the env for the next iteration. */
917
FOR_EACH (step, rest) {
918
val = EVAL(step, env);
919
CHECK_VALID_EVALED_VALUE(val);
920
actuals = CONS(val, actuals);
922
/* the envs for each iteration must be isolated and not be
924
env = scm_extend_environment(formals, actuals, orig_env);
926
#if SCM_STRICT_ARGCHECK
927
/* no iteration occurred */
928
if (rest_commands == commands)
929
ENSURE_PROPER_ARG_LIST(commands);
932
/* R5RS: If no <expression>s are present, then the value of the `do'
933
* expression is unspecified. */
934
eval_state->env = env;
936
eval_state->ret_type = SCM_VALTYPE_AS_IS;
939
#if SCM_STRICT_TOPLEVEL_DEFINITIONS
940
eval_state->nest = SCM_NEST_COMMAND;
942
return scm_s_begin(exps, eval_state);
946
ERR_OBJ(ERRMSG_INVALID_BINDINGS, bindings);
951
/*=======================================
952
R5RS : 5.2 Definitions
953
=======================================*/
955
scm_s_define_internal(enum ScmObjType permitted,
956
ScmObj var, ScmObj exp, ScmObj env)
959
DECLARE_INTERNAL_FUNCTION("define");
961
#if SCM_USE_HYGIENIC_MACRO
962
SCM_ASSERT(SYMBOLP(var) || SYMBOLP(SCM_FARSYMBOL_SYM(var)));
964
SCM_ASSERT(SYMBOLP(var));
966
var = SCM_UNWRAP_KEYWORD(var);
967
val = EVAL(exp, env);
968
CHECK_VALID_BINDEE(permitted, val);
970
SCM_SYMBOL_SET_VCELL(var, val);
973
/* To test ScmNestState, scm_s_define() needs eval_state although this is not a
974
* tail-recursive syntax */
976
scm_s_define(ScmObj var, ScmObj rest, ScmEvalState *eval_state)
978
ScmObj procname, body, formals, proc, env;
979
DECLARE_FUNCTION("define", syntax_variadic_tailrec_1);
981
/* internal definitions are handled as a virtual letrec in
983
if (!SCM_DEFINABLE_TOPLEVELP(eval_state)) {
984
#if SCM_STRICT_TOPLEVEL_DEFINITIONS
985
if (scm_toplevel_environmentp(eval_state->env))
986
ERR_OBJ("toplevel definition is not allowed here", var);
989
ERR_OBJ(ERRMSG_BAD_DEFINE_PLACEMENT, var);
991
env = eval_state->env;
993
/*=======================================================================
994
(define <variable> <expression>)
995
=======================================================================*/
996
if (IDENTIFIERP(var)) {
1000
scm_s_define_internal(ScmFirstClassObj, var, CAR(rest), env);
1003
/*=======================================================================
1004
(define (<variable> . <formals>) <body>)
1006
=> (define <variable>
1007
(lambda <formals> <body>))
1008
=======================================================================*/
1009
else if (CONSP(var)) {
1010
procname = CAR(var);
1014
ENSURE_SYMBOL(procname);
1015
proc = scm_s_lambda(formals, body, env);
1016
scm_s_define_internal(ScmFirstClassObj, procname, proc, env);
1021
eval_state->ret_type = SCM_VALTYPE_AS_IS;
1029
ERR_OBJ(ERRMSG_BAD_DEFINE_FORM,
1030
CONS(l_sym_define, CONS(var, rest)));
added
removed
sigscheme/src/syntax.c
