-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2012
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
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)
SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate)
#define LET(src, names, gensyms, vals, body) \
SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
-#define LETREC(src, names, gensyms, vals, body) \
- SCM_MAKE_EXPANDED_LETREC(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)
SCM_SYNTAX ("and", expand_and);
SCM_SYNTAX ("cond", expand_cond);
SCM_SYNTAX ("letrec", expand_letrec);
+SCM_SYNTAX ("letrec*", expand_letrec_star);
SCM_SYNTAX ("let*", expand_letstar);
SCM_SYNTAX ("or", expand_or);
SCM_SYNTAX ("lambda*", expand_lambda_star);
return TOPLEVEL_REF (SCM_BOOL_F, exp);
}
else
- return CONST (SCM_BOOL_F, exp);
+ return CONST_ (SCM_BOOL_F, exp);
}
static SCM
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);
|| 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
expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
{
SCM req, opt, kw, allow_other_keys, rest, formals, vars, body, tmp;
- SCM inits, kw_indices;
+ SCM inits;
int nreq, nopt;
const long length = scm_ilength (clause);
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)),
env = scm_acons (rest, CAR (vars), env);
}
- /* Build up kw inits, env, and kw-indices alist */
+ /* Build up kw inits, env, and kw-canon list */
if (scm_is_null (kw))
kw = SCM_BOOL_F;
else
{
- int idx = nreq + nopt + (scm_is_true (rest) ? 1 : 0);
-
- kw_indices = SCM_EOL;
+ SCM kw_canon = SCM_EOL;
kw = scm_reverse_x (kw, SCM_UNDEFINED);
for (tmp = kw; scm_is_pair (tmp); tmp = scm_cdr (tmp))
{
else
syntax_error (s_bad_formals, CAR (clause), SCM_UNDEFINED);
- kw_indices = scm_acons (k, SCM_I_MAKINUM (idx++), kw_indices);
inits = scm_cons (expand (init, env), inits);
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
+ kw_canon = scm_cons (scm_list_3 (k, sym, CAR (vars)), kw_canon);
env = scm_acons (sym, CAR (vars), env);
}
- kw_indices = scm_reverse_x (kw_indices, SCM_UNDEFINED);
- kw = scm_cons (allow_other_keys, kw_indices);
+ kw_canon = scm_reverse_x (kw_canon, SCM_UNDEFINED);
+ kw = scm_cons (allow_other_keys, kw_canon);
}
/* We should check for no duplicates, but given that psyntax does this
inner_env = expand_env_extend (inner_env, var_names, var_syms);
return LETREC
- (scm_source_properties (expr),
+ (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,
}
static SCM
-expand_letrec (SCM expr, SCM env)
+expand_letrec_helper (SCM expr, SCM env, SCM in_order_p)
{
SCM bindings;
SCM var_names, var_syms, inits;
transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
env = expand_env_extend (env, var_names, var_syms);
- return LETREC (SCM_BOOL_F,
+ return LETREC (SCM_BOOL_F, in_order_p,
var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr), env));
}
}
+static SCM
+expand_letrec (SCM expr, SCM env)
+{
+ return expand_letrec_helper (expr, env, SCM_BOOL_F);
+}
+
+static SCM
+expand_letrec_star (SCM expr, SCM env)
+{
+ return expand_letrec_helper (expr, env, SCM_BOOL_T);
+}
+
static SCM
expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
{
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
HCoop / bpt / guile.git / blobdiff