/* FIXME: Remove named let in this boot expander. */
static SCM
expand_named_let (const SCM expr, SCM env)
{
SCM var_names, var_syms, inits;
SCM inner_env;
SCM name_sym;
const SCM cdr_expr = CDR (expr);
const SCM name = CAR (cdr_expr);
const SCM cddr_expr = CDR (cdr_expr);
const SCM bindings = CAR (cddr_expr);
check_bindings (bindings, expr);
transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
name_sym = scm_gensym (SCM_UNDEFINED);
inner_env = scm_acons (name, name_sym, env);
inner_env = expand_env_extend (inner_env, var_names, var_syms);
return LETREC
(scm_source_properties (expr), SCM_BOOL_F,
scm_list_1 (name), scm_list_1 (name_sym),
scm_list_1 (LAMBDA (SCM_BOOL_F,
SCM_EOL,
LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_BOOL_F, SCM_BOOL_F,
SCM_BOOL_F, SCM_BOOL_F, var_syms,
expand_sequence (CDDDR (expr), inner_env),
SCM_BOOL_F))),
CALL (SCM_BOOL_F,
LEXICAL_REF (SCM_BOOL_F, name, name_sym),
expand_exprs (inits, env)));
}
//one arg: exp
static cellpoint letstar_2_nested_lets(void)
{
//get the reverse list of bindings list
args_push(args_ref(1));
reg = letstar_bindings();
args_push(reg);
reg = reverse();
stack_push(&vars_stack, reg);
//get body of let* expression
args_push(args_ref(1));
reg = letstar_body();
//create nested lets
if (is_true(is_null(stack_top(&vars_stack)))){
args_push(reg);
args_push(stack_pop(&vars_stack));
reg = make_let();
}else {
while (is_false(is_null(stack_top(&vars_stack)))){
check_bindings("let*", car(stack_top(&vars_stack)), args_ref(1));
args_push(reg);
args_push(cons(car(stack_top(&vars_stack)), NIL));
reg = make_let();
reg = cons(reg, NIL);
//renews bingdings
stack_push(&vars_stack, cdr(stack_pop(&vars_stack)));
}
stack_pop(&vars_stack);
reg = car(reg);
}
args_pop(1);
return reg;
}
static SCM
expand_let (SCM expr, SCM env)
{
SCM bindings;
const SCM cdr_expr = CDR (expr);
const long length = scm_ilength (cdr_expr);
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
bindings = CAR (cdr_expr);
if (scm_is_symbol (bindings))
{
ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
return expand_named_let (expr, env);
}
check_bindings (bindings, expr);
if (scm_is_null (bindings))
return expand_sequence (CDDR (expr), env);
else
{
SCM var_names, var_syms, inits;
transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
return LET (SCM_BOOL_F,
var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr),
expand_env_extend (env, var_names,
var_syms)));
}
}
//one arg: exp
static cellpoint let_vals(void)
{
args_push(args_ref(1));
reg = let_bindings();
stack_push(&vars_stack, NIL);
while (is_false(is_null(reg))){
check_bindings("let", car(reg), args_ref(1));
stack_push(&vars_stack, cons(car(cdr(car(reg))), stack_pop(&vars_stack)));
reg = cdr(reg);
}
args_push(stack_pop(&vars_stack));
reg = reverse();
args_pop(1);
return reg;
}