-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013,2014
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
SCM scm_exp_vtable_vtable;
static SCM exp_vtables[SCM_NUM_EXPANDED_TYPES];
static size_t exp_nfields[SCM_NUM_EXPANDED_TYPES];
+static SCM const_unbound;
static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
-#define VOID(src) \
+/* The trailing underscores on these first to are to avoid spurious
+ conflicts with macros defined on MinGW. */
+
+#define VOID_(src) \
SCM_MAKE_EXPANDED_VOID(src)
-#define CONST(src, exp) \
+#define CONST_(src, exp) \
SCM_MAKE_EXPANDED_CONST(src, exp)
-#define PRIMITIVE_REF_TYPE(src, name) \
- SCM_MAKE_EXPANDED_PRIMITIVE_REF_TYPE(src, name)
+#define PRIMITIVE_REF(src, name) \
+ SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name)
#define LEXICAL_REF(src, name, gensym) \
SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
#define LEXICAL_SET(src, name, gensym, exp) \
SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp)
#define CONDITIONAL(src, test, consequent, alternate) \
SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
+#define PRIMCALL(src, name, exps) \
+ SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps)
#define CALL(src, proc, exps) \
SCM_MAKE_EXPANDED_CALL(src, proc, exps)
#define SEQ(src, head, tail) \
SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
#define LETREC(src, in_order_p, names, gensyms, vals, body) \
SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
-#define DYNLET(src, fluids, vals, body) \
- SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body)
#define CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(x)
#define CDDDR(x) SCM_CDDDR(x)
#define CADDDR(x) SCM_CADDDR(x)
+/* Abbreviate SCM_EXPANDED_REF. */
+#define REF(x,type,field) \
+ (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
+
static const char s_bad_expression[] = "Bad expression";
static const char s_expression[] = "Missing or extra expression in";
SCM_SYNTAX ("@@", expand_atat);
SCM_SYNTAX ("begin", expand_begin);
SCM_SYNTAX ("define", expand_define);
-SCM_SYNTAX ("with-fluids", expand_with_fluids);
SCM_SYNTAX ("eval-when", expand_eval_when);
SCM_SYNTAX ("if", expand_if);
SCM_SYNTAX ("lambda", expand_lambda);
SCM_SYNTAX ("case-lambda*", expand_case_lambda_star);
-SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
-SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values, "@call-with-values");
-SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
-SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc, "@call-with-current-continuation");
SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
-SCM_GLOBAL_SYMBOL (scm_sym_at_dynamic_wind, "@dynamic-wind");
-SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids");
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
-SCM_GLOBAL_SYMBOL (scm_sym_at_prompt, "@prompt");
+SCM_SYMBOL (sym_call_with_prompt, "call-with-prompt");
SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
SCM_SYMBOL (sym_lambda_star, "lambda*");
SCM_SYMBOL (sym_eval, "eval");
SCM_SYMBOL (sym_load, "load");
+SCM_SYMBOL (sym_primitive, "primitive");
SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
{
SCM arg_exps = SCM_EOL;
SCM args = SCM_EOL;
- SCM proc = CAR (exp);
+ SCM proc = expand (CAR (exp), env);
for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
arg_exps = CDR (arg_exps))
args = scm_cons (expand (CAR (arg_exps), env), args);
- if (scm_is_null (arg_exps))
- return CALL (scm_source_properties (exp),
- expand (proc, env),
- scm_reverse_x (args, SCM_UNDEFINED));
- else
+ args = scm_reverse_x (args, SCM_UNDEFINED);
+
+ if (!scm_is_null (arg_exps))
syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
+
+ if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF)
+ return PRIMCALL (scm_source_properties (exp),
+ SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
+ args);
+ else
+ return CALL (scm_source_properties (exp), proc, args);
}
}
else if (scm_is_symbol (exp))
return TOPLEVEL_REF (SCM_BOOL_F, exp);
}
else
- return CONST (SCM_BOOL_F, exp);
+ return CONST_ (SCM_BOOL_F, exp);
}
static SCM
expand_atat (SCM expr, SCM env SCM_UNUSED)
{
ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
+ if (scm_is_eq (CADR (expr), sym_primitive))
+ return PRIMITIVE_REF (scm_source_properties (expr), CADDR (expr));
+
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
return MODULE_REF (scm_source_properties (expr),
CADR (expr), CADDR (expr), SCM_BOOL_F);
}
const SCM cdr_expr = CDR (expr);
if (scm_is_null (cdr_expr))
- return CONST (SCM_BOOL_F, SCM_BOOL_T);
+ return CONST_ (SCM_BOOL_F, SCM_BOOL_T);
ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
return CONDITIONAL (scm_source_properties (expr),
expand (CAR (cdr_expr), env),
expand_and (cdr_expr, env),
- CONST (SCM_BOOL_F, SCM_BOOL_F));
+ CONST_ (SCM_BOOL_F, SCM_BOOL_F));
}
static SCM
}
if (scm_is_null (rest))
- rest = VOID (SCM_BOOL_F);
+ rest = VOID_ (SCM_BOOL_F);
else
rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
expand (CAR (body), env));
}
-static SCM
-expand_with_fluids (SCM expr, SCM env)
-{
- SCM binds, fluids, vals;
- ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
- binds = CADR (expr);
- ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr);
- for (fluids = SCM_EOL, vals = SCM_EOL;
- scm_is_pair (binds);
- binds = CDR (binds))
- {
- SCM binding = CAR (binds);
- ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding,
- binding, expr);
- fluids = scm_cons (expand (CAR (binding), env), fluids);
- vals = scm_cons (expand (CADR (binding), env), vals);
- }
-
- return DYNLET (scm_source_properties (expr),
- scm_reverse_x (fluids, SCM_UNDEFINED),
- scm_reverse_x (vals, SCM_UNDEFINED),
- expand_sequence (CDDR (expr), env));
-}
-
static SCM
expand_eval_when (SCM expr, SCM env)
{
|| scm_is_true (scm_memq (sym_load, CADR (expr))))
return expand_sequence (CDDR (expr), env);
else
- return VOID (scm_source_properties (expr));
+ return VOID_ (scm_source_properties (expr));
}
static SCM
expand (CADDR (expr), env),
((length == 3)
? expand (CADDDR (expr), env)
- : VOID (SCM_BOOL_F)));
+ : VOID_ (SCM_BOOL_F)));
}
/* A helper function for expand_lambda to support checking for duplicate
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (x, CAR (vars), env);
if (scm_is_symbol (x))
- inits = scm_cons (CONST (SCM_BOOL_F, SCM_BOOL_F), inits);
+ inits = scm_cons (CONST_ (SCM_BOOL_F, SCM_BOOL_F), inits);
else
{
ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
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,
+ LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F,
+ SCM_BOOL_F, SCM_EOL, var_syms,
expand_sequence (CDDDR (expr), inner_env),
SCM_BOOL_F))),
CALL (SCM_BOOL_F,
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
if (scm_is_null (CDR (expr)))
- return CONST (SCM_BOOL_F, SCM_BOOL_F);
+ return CONST_ (SCM_BOOL_F, SCM_BOOL_F);
else
{
SCM tmp = scm_gensym (SCM_UNDEFINED);
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
quotee = CAR (cdr_expr);
- return CONST (scm_source_properties (expr), quotee);
+ return CONST_ (scm_source_properties (expr), quotee);
}
static SCM
#undef FUNC_NAME
- \f
+\f
+
+static void
+compute_assigned (SCM exp, SCM assigned)
+{
+ if (scm_is_null (exp) || scm_is_false (exp))
+ return;
+
+ if (scm_is_pair (exp))
+ {
+ compute_assigned (CAR (exp), assigned);
+ compute_assigned (CDR (exp), assigned);
+ return;
+ }
+
+ if (!SCM_EXPANDED_P (exp))
+ abort ();
+
+ switch (SCM_EXPANDED_TYPE (exp))
+ {
+ case SCM_EXPANDED_VOID:
+ case SCM_EXPANDED_CONST:
+ case SCM_EXPANDED_PRIMITIVE_REF:
+ case SCM_EXPANDED_LEXICAL_REF:
+ case SCM_EXPANDED_MODULE_REF:
+ case SCM_EXPANDED_TOPLEVEL_REF:
+ return;
+
+ case SCM_EXPANDED_LEXICAL_SET:
+ scm_hashq_set_x (assigned, REF (exp, LEXICAL_SET, GENSYM), SCM_BOOL_T);
+ compute_assigned (REF (exp, LEXICAL_SET, EXP), assigned);
+ return;
+
+ case SCM_EXPANDED_MODULE_SET:
+ compute_assigned (REF (exp, MODULE_SET, EXP), assigned);
+ return;
+
+ case SCM_EXPANDED_TOPLEVEL_SET:
+ compute_assigned (REF (exp, TOPLEVEL_SET, EXP), assigned);
+ return;
+
+ case SCM_EXPANDED_TOPLEVEL_DEFINE:
+ compute_assigned (REF (exp, TOPLEVEL_DEFINE, EXP), assigned);
+ return;
+
+ case SCM_EXPANDED_CONDITIONAL:
+ compute_assigned (REF (exp, CONDITIONAL, TEST), assigned);
+ compute_assigned (REF (exp, CONDITIONAL, CONSEQUENT), assigned);
+ compute_assigned (REF (exp, CONDITIONAL, ALTERNATE), assigned);
+ return;
+
+ case SCM_EXPANDED_CALL:
+ compute_assigned (REF (exp, CALL, PROC), assigned);
+ compute_assigned (REF (exp, CALL, ARGS), assigned);
+ return;
+
+ case SCM_EXPANDED_PRIMCALL:
+ compute_assigned (REF (exp, PRIMCALL, ARGS), assigned);
+ return;
+
+ case SCM_EXPANDED_SEQ:
+ compute_assigned (REF (exp, SEQ, HEAD), assigned);
+ compute_assigned (REF (exp, SEQ, TAIL), assigned);
+ return;
+
+ case SCM_EXPANDED_LAMBDA:
+ compute_assigned (REF (exp, LAMBDA, BODY), assigned);
+ return;
+
+ case SCM_EXPANDED_LAMBDA_CASE:
+ compute_assigned (REF (exp, LAMBDA_CASE, INITS), assigned);
+ compute_assigned (REF (exp, LAMBDA_CASE, BODY), assigned);
+ compute_assigned (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
+ return;
+
+ case SCM_EXPANDED_LET:
+ compute_assigned (REF (exp, LET, VALS), assigned);
+ compute_assigned (REF (exp, LET, BODY), assigned);
+ return;
+
+ case SCM_EXPANDED_LETREC:
+ {
+ SCM syms = REF (exp, LETREC, GENSYMS);
+ /* We lower letrec in this same pass, so mark these variables as
+ assigned. */
+ for (; scm_is_pair (syms); syms = CDR (syms))
+ scm_hashq_set_x (assigned, CAR (syms), SCM_BOOL_T);
+ }
+ compute_assigned (REF (exp, LETREC, VALS), assigned);
+ compute_assigned (REF (exp, LETREC, BODY), assigned);
+ return;
+
+ default:
+ abort ();
+ }
+}
+
+static SCM
+box_value (SCM exp)
+{
+ return PRIMCALL (SCM_BOOL_F, scm_from_latin1_symbol ("make-variable"),
+ scm_list_1 (exp));
+}
+
+static SCM
+box_lexical (SCM name, SCM sym)
+{
+ return LEXICAL_SET (SCM_BOOL_F, name, sym,
+ box_value (LEXICAL_REF (SCM_BOOL_F, name, sym)));
+}
+
+static SCM
+init_if_unbound (SCM src, SCM name, SCM sym, SCM init)
+{
+ return CONDITIONAL (src,
+ PRIMCALL (src,
+ scm_from_latin1_symbol ("eq?"),
+ scm_list_2 (LEXICAL_REF (src, name, sym),
+ const_unbound)),
+ LEXICAL_SET (src, name, sym, init),
+ VOID_ (src));
+}
+
+static SCM
+init_boxes (SCM names, SCM syms, SCM vals, SCM body)
+{
+ if (scm_is_null (names)) return body;
+
+ return SEQ (SCM_BOOL_F,
+ PRIMCALL
+ (SCM_BOOL_F,
+ scm_from_latin1_symbol ("variable-set!"),
+ scm_list_2 (LEXICAL_REF (SCM_BOOL_F, CAR (names), CAR (syms)),
+ CAR (vals))),
+ init_boxes (CDR (names), CDR (syms), CDR (vals), body));
+}
+
+static SCM
+convert_assignment (SCM exp, SCM assigned)
+{
+ if (scm_is_null (exp) || scm_is_false (exp))
+ return exp;
+
+ if (scm_is_pair (exp))
+ return scm_cons (convert_assignment (CAR (exp), assigned),
+ convert_assignment (CDR (exp), assigned));
+
+ if (!SCM_EXPANDED_P (exp))
+ abort ();
+
+ switch (SCM_EXPANDED_TYPE (exp))
+ {
+ case SCM_EXPANDED_VOID:
+ case SCM_EXPANDED_CONST:
+ case SCM_EXPANDED_PRIMITIVE_REF:
+ case SCM_EXPANDED_MODULE_REF:
+ case SCM_EXPANDED_TOPLEVEL_REF:
+ return exp;
+
+ case SCM_EXPANDED_LEXICAL_REF:
+ {
+ SCM sym = REF (exp, LEXICAL_REF, GENSYM);
+
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ return PRIMCALL
+ (REF (exp, LEXICAL_REF, SRC),
+ scm_from_latin1_symbol ("variable-ref"),
+ scm_list_1 (exp));
+ return exp;
+ }
+
+ case SCM_EXPANDED_LEXICAL_SET:
+ return PRIMCALL
+ (REF (exp, LEXICAL_SET, SRC),
+ scm_from_latin1_symbol ("variable-set!"),
+ scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, SRC),
+ REF (exp, LEXICAL_SET, NAME),
+ REF (exp, LEXICAL_SET, GENSYM)),
+ convert_assignment (REF (exp, LEXICAL_SET, EXP),
+ assigned)));
+
+ case SCM_EXPANDED_MODULE_SET:
+ return MODULE_SET
+ (REF (exp, MODULE_SET, SRC),
+ REF (exp, MODULE_SET, MOD),
+ REF (exp, MODULE_SET, NAME),
+ REF (exp, MODULE_SET, PUBLIC),
+ convert_assignment (REF (exp, MODULE_SET, EXP), assigned));
+
+ case SCM_EXPANDED_TOPLEVEL_SET:
+ return TOPLEVEL_SET
+ (REF (exp, TOPLEVEL_SET, SRC),
+ REF (exp, TOPLEVEL_SET, NAME),
+ convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned));
+
+ case SCM_EXPANDED_TOPLEVEL_DEFINE:
+ return TOPLEVEL_DEFINE
+ (REF (exp, TOPLEVEL_DEFINE, SRC),
+ REF (exp, TOPLEVEL_DEFINE, NAME),
+ convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP),
+ assigned));
+
+ case SCM_EXPANDED_CONDITIONAL:
+ return CONDITIONAL
+ (REF (exp, CONDITIONAL, SRC),
+ convert_assignment (REF (exp, CONDITIONAL, TEST), assigned),
+ convert_assignment (REF (exp, CONDITIONAL, CONSEQUENT), assigned),
+ convert_assignment (REF (exp, CONDITIONAL, ALTERNATE), assigned));
+
+ case SCM_EXPANDED_CALL:
+ return CALL
+ (REF (exp, CALL, SRC),
+ convert_assignment (REF (exp, CALL, PROC), assigned),
+ convert_assignment (REF (exp, CALL, ARGS), assigned));
+
+ case SCM_EXPANDED_PRIMCALL:
+ return PRIMCALL
+ (REF (exp, PRIMCALL, SRC),
+ REF (exp, PRIMCALL, NAME),
+ convert_assignment (REF (exp, PRIMCALL, ARGS), assigned));
+
+ case SCM_EXPANDED_SEQ:
+ return SEQ
+ (REF (exp, SEQ, SRC),
+ convert_assignment (REF (exp, SEQ, HEAD), assigned),
+ convert_assignment (REF (exp, SEQ, TAIL), assigned));
+
+ case SCM_EXPANDED_LAMBDA:
+ return LAMBDA
+ (REF (exp, LAMBDA, SRC),
+ REF (exp, LAMBDA, META),
+ convert_assignment (REF (exp, LAMBDA, BODY), assigned));
+
+ case SCM_EXPANDED_LAMBDA_CASE:
+ {
+ SCM src, req, opt, rest, kw, inits, syms, body, alt;
+ SCM namewalk, symwalk, new_inits, seq;
+
+ /* Box assigned formals. Since initializers can capture
+ previous formals, we convert initializers to be in the body
+ instead of in the "header". */
+
+ src = REF (exp, LAMBDA_CASE, SRC);
+ req = REF (exp, LAMBDA_CASE, REQ);
+ opt = REF (exp, LAMBDA_CASE, OPT);
+ rest = REF (exp, LAMBDA_CASE, REST);
+ kw = REF (exp, LAMBDA_CASE, KW);
+ inits = convert_assignment (REF (exp, LAMBDA_CASE, INITS), assigned);
+ syms = REF (exp, LAMBDA_CASE, GENSYMS);
+ body = convert_assignment (REF (exp, LAMBDA_CASE, BODY), assigned);
+ alt = convert_assignment (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
+
+ new_inits = scm_make_list (scm_length (inits), const_unbound);
+
+ seq = SCM_EOL, symwalk = syms;
+
+ /* Required arguments may need boxing. */
+ for (namewalk = req;
+ scm_is_pair (namewalk);
+ namewalk = CDR (namewalk), symwalk = CDR (symwalk))
+ {
+ SCM name = CAR (namewalk), sym = CAR (symwalk);
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ seq = scm_cons (box_lexical (name, sym), seq);
+ }
+ /* Optional arguments may need initialization and/or boxing. */
+ for (namewalk = opt;
+ scm_is_pair (namewalk);
+ namewalk = CDR (namewalk), symwalk = CDR (symwalk),
+ inits = CDR (inits))
+ {
+ SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (inits);
+ seq = scm_cons (init_if_unbound (src, name, sym, init), seq);
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ seq = scm_cons (box_lexical (name, sym), seq);
+ }
+ /* Rest arguments may need boxing. */
+ if (scm_is_true (rest))
+ {
+ SCM sym = CAR (symwalk);
+ symwalk = CDR (symwalk);
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ seq = scm_cons (box_lexical (rest, sym), seq);
+ }
+ /* The rest of the arguments, if any, are keyword arguments,
+ which may need initialization and/or boxing. */
+ for (;
+ scm_is_pair (symwalk);
+ symwalk = CDR (symwalk), inits = CDR (inits))
+ {
+ SCM sym = CAR (symwalk), init = CAR (inits);
+ seq = scm_cons (init_if_unbound (src, SCM_BOOL_F, sym, init), seq);
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ seq = scm_cons (box_lexical (SCM_BOOL_F, sym), seq);
+ }
+
+ for (; scm_is_pair (seq); seq = CDR (seq))
+ body = SEQ (src, CAR (seq), body);
+
+ return LAMBDA_CASE
+ (src, req, opt, rest, kw, new_inits, syms, body, alt);
+ }
+
+ case SCM_EXPANDED_LET:
+ {
+ SCM src, names, syms, vals, body, new_vals, walk;
+
+ src = REF (exp, LET, SRC);
+ names = REF (exp, LET, NAMES);
+ syms = REF (exp, LET, GENSYMS);
+ vals = convert_assignment (REF (exp, LET, VALS), assigned);
+ body = convert_assignment (REF (exp, LET, BODY), assigned);
+
+ for (new_vals = SCM_EOL, walk = syms;
+ scm_is_pair (vals);
+ vals = CDR (vals), walk = CDR (walk))
+ {
+ SCM sym = CAR (walk), val = CAR (vals);
+ if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
+ new_vals = scm_cons (box_value (val), new_vals);
+ else
+ new_vals = scm_cons (val, new_vals);
+ }
+ new_vals = scm_reverse (new_vals);
+
+ return LET (src, names, syms, new_vals, body);
+ }
+
+ case SCM_EXPANDED_LETREC:
+ {
+ SCM src, names, syms, vals, empty_box, boxes, body;
+
+ src = REF (exp, LETREC, SRC);
+ names = REF (exp, LETREC, NAMES);
+ syms = REF (exp, LETREC, GENSYMS);
+ vals = convert_assignment (REF (exp, LETREC, VALS), assigned);
+ body = convert_assignment (REF (exp, LETREC, BODY), assigned);
+
+ empty_box =
+ PRIMCALL (SCM_BOOL_F,
+ scm_from_latin1_symbol ("make-undefined-variable"),
+ SCM_EOL);
+ boxes = scm_make_list (scm_length (names), empty_box);
+
+ if (scm_is_true (REF (exp, LETREC, IN_ORDER_P)))
+ return LET
+ (src, names, syms, boxes,
+ init_boxes (names, syms, vals, body));
+ else
+ {
+ SCM walk, tmps = SCM_EOL, inits = SCM_EOL;
+
+ for (walk = syms; scm_is_pair (walk); walk = CDR (walk))
+ {
+ SCM tmp = scm_gensym (SCM_UNDEFINED);
+ tmps = scm_cons (tmp, tmps);
+ inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, SCM_BOOL_F, tmp),
+ inits);
+ }
+ tmps = scm_reverse (tmps);
+ inits = scm_reverse (inits);
+
+ return LET
+ (src, names, syms, boxes,
+ SEQ (src,
+ LET (src, names, tmps, vals,
+ init_boxes (names, syms, inits, VOID_ (src))),
+ body));
+ }
+ }
+
+ default:
+ abort ();
+ }
+}
+
+SCM
+scm_convert_assignment (SCM exp)
+{
+ SCM assigned = scm_c_make_hash_table (0);
+
+ compute_assigned (exp, assigned);
+ return convert_assignment (exp, assigned);
+}
+
+
+\f
#define DEFINE_NAMES(type) \
{ \
DEFINE_NAMES (LAMBDA_CASE);
DEFINE_NAMES (LET);
DEFINE_NAMES (LETREC);
- DEFINE_NAMES (DYNLET);
scm_exp_vtable_vtable =
scm_make_vtable (scm_from_locale_string (SCM_VTABLE_BASE_LAYOUT "pwuwpw"),
while (n--)
exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list);
+ const_unbound =
+ CONST_ (SCM_BOOL_F, scm_list_1 (scm_from_latin1_symbol ("unbound")));
+
+ scm_c_define_gsubr ("convert-assignment", 1, 0, 0, scm_convert_assignment);
+
scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list));
#include "libguile/expand.x"
HCoop / bpt / guile.git / blobdiff