diff options
Diffstat (limited to 'libguile/expand.c')
-rw-r--r-- | libguile/expand.c | 355 |
1 files changed, 130 insertions, 225 deletions
diff --git a/libguile/expand.c b/libguile/expand.c index a308b9518..be95578e3 100644 --- a/libguile/expand.c +++ b/libguile/expand.c @@ -1,4 +1,4 @@ -/* Copyright 1995-2014,2016,2018-2020 +/* Copyright 1995-2014,2016,2018-2020,2025 Free Software Foundation, Inc. This file is part of Guile. @@ -37,7 +37,6 @@ #include "pairs.h" #include "ports.h" #include "print.h" -#include "srcprop.h" #include "strings.h" #include "symbols.h" #include "throw.h" @@ -61,42 +60,42 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES]; /* 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) \ - SCM_MAKE_EXPANDED_CONST(src, exp) -#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_LEXICAL_SET(src, name, gensym, exp) -#define MODULE_REF(src, mod, name, public) \ - SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public) -#define MODULE_SET(src, mod, name, public, exp) \ - SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp) -#define TOPLEVEL_REF(src, mod, name) \ - SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name) -#define TOPLEVEL_SET(src, mod, name, exp) \ - SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp) -#define TOPLEVEL_DEFINE(src, mod, name, exp) \ - SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, 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_SEQ(src, head, tail) -#define LAMBDA(src, meta, body) \ - SCM_MAKE_EXPANDED_LAMBDA(src, meta, body) -#define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \ - 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, in_order_p, names, gensyms, vals, body) \ - SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body) +#define VOID_() \ + SCM_MAKE_EXPANDED_VOID(SCM_BOOL_F) +#define CONST_(exp) \ + SCM_MAKE_EXPANDED_CONST(SCM_BOOL_F, exp) +#define PRIMITIVE_REF(name) \ + SCM_MAKE_EXPANDED_PRIMITIVE_REF(SCM_BOOL_F, name) +#define LEXICAL_REF(name, gensym) \ + SCM_MAKE_EXPANDED_LEXICAL_REF(SCM_BOOL_F, name, gensym) +#define LEXICAL_SET(name, gensym, exp) \ + SCM_MAKE_EXPANDED_LEXICAL_SET(SCM_BOOL_F, name, gensym, exp) +#define MODULE_REF(mod, name, public) \ + SCM_MAKE_EXPANDED_MODULE_REF(SCM_BOOL_F, mod, name, public) +#define MODULE_SET(mod, name, public, exp) \ + SCM_MAKE_EXPANDED_MODULE_SET(SCM_BOOL_F, mod, name, public, exp) +#define TOPLEVEL_REF(mod, name) \ + SCM_MAKE_EXPANDED_TOPLEVEL_REF(SCM_BOOL_F, mod, name) +#define TOPLEVEL_SET(mod, name, exp) \ + SCM_MAKE_EXPANDED_TOPLEVEL_SET(SCM_BOOL_F, mod, name, exp) +#define TOPLEVEL_DEFINE(mod, name, exp) \ + SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(SCM_BOOL_F, mod, name, exp) +#define CONDITIONAL(test, consequent, alternate) \ + SCM_MAKE_EXPANDED_CONDITIONAL(SCM_BOOL_F, test, consequent, alternate) +#define PRIMCALL(name, exps) \ + SCM_MAKE_EXPANDED_PRIMCALL(SCM_BOOL_F, name, exps) +#define CALL(proc, exps) \ + SCM_MAKE_EXPANDED_CALL(SCM_BOOL_F, proc, exps) +#define SEQ(head, tail) \ + SCM_MAKE_EXPANDED_SEQ(SCM_BOOL_F, head, tail) +#define LAMBDA(meta, body) \ + SCM_MAKE_EXPANDED_LAMBDA(SCM_BOOL_F, meta, body) +#define LAMBDA_CASE(req, opt, rest, kw, inits, gensyms, body, alternate) \ + SCM_MAKE_EXPANDED_LAMBDA_CASE(SCM_BOOL_F, req, opt, rest, kw, inits, gensyms, body, alternate) +#define LET(names, gensyms, vals, body) \ + SCM_MAKE_EXPANDED_LET(SCM_BOOL_F, names, gensyms, vals, body) +#define LETREC(in_order_p, names, gensyms, vals, body) \ + SCM_MAKE_EXPANDED_LETREC(SCM_BOOL_F, in_order_p, names, gensyms, vals, body) #define CAR(x) SCM_CAR(x) #define CDR(x) SCM_CDR(x) @@ -213,71 +212,22 @@ SCM_KEYWORD (kw_rest, "rest"); -/* Signal a syntax error. We distinguish between the form that caused the - * error and the enclosing expression. The error message will print out as - * shown in the following pattern. The file name and line number are only - * given when they can be determined from the erroneous form or from the - * enclosing expression. - * - * <filename>: In procedure memoization: - * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */ - static void syntax_error (const char* const msg, const SCM form, const SCM expr) { SCM msg_string = scm_from_utf8_string (msg); - SCM filename = SCM_BOOL_F; - SCM linenr = SCM_BOOL_F; const char *format; SCM args; - if (scm_is_pair (form)) - { - filename = scm_source_property (form, scm_sym_filename); - linenr = scm_source_property (form, scm_sym_line); - } - - if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr)) - { - filename = scm_source_property (expr, scm_sym_filename); - linenr = scm_source_property (expr, scm_sym_line); - } - if (!SCM_UNBNDP (expr)) { - if (scm_is_true (filename)) - { - format = "In file ~S, line ~S: ~A ~S in expression ~S."; - args = scm_list_5 (filename, linenr, msg_string, form, expr); - } - else if (scm_is_true (linenr)) - { - format = "In line ~S: ~A ~S in expression ~S."; - args = scm_list_4 (linenr, msg_string, form, expr); - } - else - { - format = "~A ~S in expression ~S."; - args = scm_list_3 (msg_string, form, expr); - } + format = "~A ~S in expression ~S."; + args = scm_list_3 (msg_string, form, expr); } else { - if (scm_is_true (filename)) - { - format = "In file ~S, line ~S: ~A ~S."; - args = scm_list_4 (filename, linenr, msg_string, form); - } - else if (scm_is_true (linenr)) - { - format = "In line ~S: ~A ~S."; - args = scm_list_3 (linenr, msg_string, form); - } - else - { - format = "~A ~S."; - args = scm_list_2 (msg_string, form); - } + format = "~A ~S."; + args = scm_list_2 (msg_string, form); } scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F); @@ -365,23 +315,22 @@ expand (SCM exp, SCM env) 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), + return PRIMCALL (SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME), args); else - return CALL (scm_source_properties (exp), proc, args); + return CALL (proc, args); } } else if (scm_is_symbol (exp)) { SCM gensym = expand_env_lexical_gensym (env, exp); if (scm_is_true (gensym)) - return LEXICAL_REF (SCM_BOOL_F, exp, gensym); + return LEXICAL_REF (exp, gensym); else - return TOPLEVEL_REF (SCM_BOOL_F, SCM_BOOL_F, exp); + return TOPLEVEL_REF (SCM_BOOL_F, exp); } else - return CONST_ (SCM_BOOL_F, exp); + return CONST_ (exp); } static SCM @@ -402,8 +351,7 @@ expand_sequence (const SCM forms, const SCM env) if (scm_is_null (CDR (forms))) return expand (CAR (forms), env); else - return SEQ (scm_source_properties (forms), - expand (CAR (forms), env), + return SEQ (expand (CAR (forms), env), expand_sequence (CDR (forms), env)); } @@ -418,8 +366,7 @@ expand_at (SCM expr, SCM env SCM_UNUSED) ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr); ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr); - return MODULE_REF (scm_source_properties (expr), - CADR (expr), CADDR (expr), SCM_BOOL_T); + return MODULE_REF (CADR (expr), CADDR (expr), SCM_BOOL_T); } static SCM @@ -429,11 +376,10 @@ expand_atat (SCM expr, SCM env SCM_UNUSED) 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)); + return PRIMITIVE_REF (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); + return MODULE_REF (CADR (expr), CADDR (expr), SCM_BOOL_F); } static SCM @@ -442,17 +388,16 @@ expand_and (SCM expr, SCM env) const SCM cdr_expr = CDR (expr); if (scm_is_null (cdr_expr)) - return CONST_ (SCM_BOOL_F, SCM_BOOL_T); + return CONST_ (SCM_BOOL_T); ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr); if (scm_is_null (CDR (cdr_expr))) return expand (CAR (cdr_expr), env); else - return CONDITIONAL (scm_source_properties (expr), - expand (CAR (cdr_expr), env), + return CONDITIONAL (expand (CAR (cdr_expr), env), expand_and (cdr_expr, env), - CONST_ (SCM_BOOL_F, SCM_BOOL_F)); + CONST_ (SCM_BOOL_F)); } static SCM @@ -480,7 +425,7 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env) } if (scm_is_null (rest)) - rest = VOID_ (SCM_BOOL_F); + rest = VOID_ (); else rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env); @@ -492,22 +437,17 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env) SCM new_env = scm_acons (tmp, tmp, env); ASSERT_SYNTAX (length > 2, s_missing_recipient, clause); ASSERT_SYNTAX (length == 3, s_extra_expression, clause); - return LET (SCM_BOOL_F, - scm_list_1 (tmp), + return LET (scm_list_1 (tmp), scm_list_1 (tmp), scm_list_1 (expand (test, env)), - CONDITIONAL (SCM_BOOL_F, - LEXICAL_REF (SCM_BOOL_F, tmp, tmp), - CALL (SCM_BOOL_F, - expand (CADDR (clause), new_env), - scm_list_1 (LEXICAL_REF (SCM_BOOL_F, - tmp, tmp))), + CONDITIONAL (LEXICAL_REF (tmp, tmp), + CALL (expand (CADDR (clause), new_env), + scm_list_1 (LEXICAL_REF (tmp, tmp))), rest)); } /* FIXME length == 1 case */ else - return CONDITIONAL (SCM_BOOL_F, - expand (test, env), + return CONDITIONAL (expand (test, env), expand_sequence (CDR (clause), env), rest); } @@ -552,15 +492,14 @@ expand_define (SCM expr, SCM env) { ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr); return TOPLEVEL_DEFINE - (scm_source_properties (expr), - SCM_BOOL_F, + (SCM_BOOL_F, CAR (variable), expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)), env)); } ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr); ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr); - return TOPLEVEL_DEFINE (scm_source_properties (expr), SCM_BOOL_F, variable, + return TOPLEVEL_DEFINE (SCM_BOOL_F, variable, expand (CAR (body), env)); } @@ -574,7 +513,7 @@ 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_ (); } static SCM @@ -583,12 +522,11 @@ expand_if (SCM expr, SCM env SCM_UNUSED) const SCM cdr_expr = CDR (expr); const long length = scm_ilength (cdr_expr); ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr); - return CONDITIONAL (scm_source_properties (expr), - expand (CADR (expr), env), + return CONDITIONAL (expand (CADR (expr), env), expand (CADDR (expr), env), ((length == 3) ? expand (CADDDR (expr), env) - : VOID_ (SCM_BOOL_F))); + : VOID_ ())); } /* A helper function for expand_lambda to support checking for duplicate @@ -666,15 +604,14 @@ expand_lambda_case (SCM clause, SCM alternate, SCM env) if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE)) abort (); - return LAMBDA_CASE (SCM_BOOL_F, req, SCM_BOOL_F, rest, SCM_BOOL_F, + return LAMBDA_CASE (req, SCM_BOOL_F, rest, SCM_BOOL_F, SCM_EOL, vars, body, alternate); } static SCM expand_lambda (SCM expr, SCM env) { - return LAMBDA (scm_source_properties (expr), - SCM_EOL, + return LAMBDA (SCM_EOL, expand_lambda_case (CDR (expr), SCM_BOOL_F, env)); } @@ -777,7 +714,7 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env) 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), inits); else { ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)), @@ -845,15 +782,14 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env) inits = scm_reverse_x (inits, SCM_UNDEFINED); body = expand_sequence (body, env); - return LAMBDA_CASE (SCM_BOOL_F, req, opt, rest, kw, inits, vars, body, + return LAMBDA_CASE (req, opt, rest, kw, inits, vars, body, alternate); } static SCM expand_lambda_star (SCM expr, SCM env) { - return LAMBDA (scm_source_properties (expr), - SCM_EOL, + return LAMBDA (SCM_EOL, expand_lambda_star_case (CDR (expr), SCM_BOOL_F, env)); } @@ -875,8 +811,7 @@ expand_case_lambda (SCM expr, SCM env) { ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr); - return LAMBDA (scm_source_properties (expr), - SCM_EOL, + return LAMBDA (SCM_EOL, expand_case_lambda_clauses (CADR (expr), CDDR (expr), env)); } @@ -898,8 +833,7 @@ expand_case_lambda_star (SCM expr, SCM env) { ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr); - return LAMBDA (scm_source_properties (expr), - SCM_EOL, + return LAMBDA (SCM_EOL, expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env)); } @@ -973,16 +907,14 @@ expand_named_let (const SCM expr, SCM env) inner_env = expand_env_extend (inner_env, var_names, var_syms); return LETREC - (scm_source_properties (expr), SCM_BOOL_F, + (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_EOL, SCM_BOOL_F, + scm_list_1 (LAMBDA (SCM_EOL, + LAMBDA_CASE (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, - LEXICAL_REF (SCM_BOOL_F, name, name_sym), + CALL (LEXICAL_REF (name, name_sym), expand_exprs (inits, env))); } @@ -1010,8 +942,7 @@ expand_let (SCM expr, SCM env) { 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), + return LET (var_names, var_syms, expand_exprs (inits, env), expand_sequence (CDDR (expr), expand_env_extend (env, var_names, var_syms))); @@ -1037,7 +968,7 @@ expand_letrec_helper (SCM expr, SCM env, SCM in_order_p) 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, in_order_p, + return LETREC (in_order_p, var_names, var_syms, expand_exprs (inits, env), expand_sequence (CDDR (expr), env)); } @@ -1071,7 +1002,7 @@ expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED) sym = scm_gensym (SCM_UNDEFINED); init = CADR (bind); - return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym), + return LET (scm_list_1 (name), scm_list_1 (sym), scm_list_1 (expand (init, env)), expand_letstar_clause (CDR (bindings), body, scm_acons (name, sym, env))); @@ -1097,16 +1028,14 @@ expand_or (SCM expr, 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); else { SCM tmp = scm_gensym (SCM_UNDEFINED); - return LET (SCM_BOOL_F, - scm_list_1 (tmp), scm_list_1 (tmp), + return LET (scm_list_1 (tmp), scm_list_1 (tmp), scm_list_1 (expand (CADR (expr), env)), - CONDITIONAL (SCM_BOOL_F, - LEXICAL_REF (SCM_BOOL_F, tmp, tmp), - LEXICAL_REF (SCM_BOOL_F, tmp, tmp), + CONDITIONAL (LEXICAL_REF (tmp, tmp), + LEXICAL_REF (tmp, tmp), expand_or (CDR (expr), scm_acons (tmp, tmp, env)))); } @@ -1121,7 +1050,7 @@ expand_quote (SCM expr, SCM env SCM_UNUSED) 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_ (quotee); } static SCM @@ -1139,18 +1068,15 @@ expand_set_x (SCM expr, SCM env) switch (SCM_EXPANDED_TYPE (vmem)) { case SCM_EXPANDED_LEXICAL_REF: - return LEXICAL_SET (scm_source_properties (expr), - SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME), + return LEXICAL_SET (SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME), SCM_EXPANDED_REF (vmem, LEXICAL_REF, GENSYM), expand (CADDR (expr), env)); case SCM_EXPANDED_TOPLEVEL_REF: - return TOPLEVEL_SET (scm_source_properties (expr), - SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD), + return TOPLEVEL_SET (SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD), SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME), expand (CADDR (expr), env)); case SCM_EXPANDED_MODULE_REF: - return MODULE_SET (scm_source_properties (expr), - SCM_EXPANDED_REF (vmem, MODULE_REF, MOD), + return MODULE_SET (SCM_EXPANDED_REF (vmem, MODULE_REF, MOD), SCM_EXPANDED_REF (vmem, MODULE_REF, NAME), SCM_EXPANDED_REF (vmem, MODULE_REF, PUBLIC), expand (CADDR (expr), env)); @@ -1282,27 +1208,25 @@ compute_assigned (SCM exp, SCM assigned) static SCM box_value (SCM exp) { - return PRIMCALL (SCM_BOOL_F, scm_from_latin1_symbol ("make-variable"), + return PRIMCALL (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))); + return LEXICAL_SET (name, sym, + box_value (LEXICAL_REF (name, sym))); } static SCM -init_if_unbound (SCM src, SCM name, SCM sym, SCM init) +init_if_unbound (SCM name, SCM sym, SCM init) { - return CONDITIONAL (src, - PRIMCALL (src, - scm_from_latin1_symbol ("eq?"), - scm_list_2 (LEXICAL_REF (src, name, sym), + return CONDITIONAL (PRIMCALL (scm_from_latin1_symbol ("eq?"), + scm_list_2 (LEXICAL_REF (name, sym), const_unbound)), - LEXICAL_SET (src, name, sym, init), - VOID_ (src)); + LEXICAL_SET (name, sym, init), + VOID_ ()); } static SCM @@ -1310,11 +1234,9 @@ 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)), + return SEQ (PRIMCALL + (scm_from_latin1_symbol ("variable-set!"), + scm_list_2 (LEXICAL_REF (CAR (names), CAR (syms)), CAR (vals))), init_boxes (CDR (names), CDR (syms), CDR (vals), body)); } @@ -1347,100 +1269,87 @@ convert_assignment (SCM exp, SCM assigned) 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_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), + (scm_from_latin1_symbol ("variable-set!"), + scm_list_2 (LEXICAL_REF (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, 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, MOD), + (REF (exp, TOPLEVEL_SET, MOD), 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, MOD), + (REF (exp, TOPLEVEL_DEFINE, MOD), 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, 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, PROC), assigned), convert_assignment (REF (exp, CALL, ARGS), assigned)); case SCM_EXPANDED_PRIMCALL: return PRIMCALL - (REF (exp, PRIMCALL, SRC), - REF (exp, PRIMCALL, NAME), + (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, HEAD), assigned), convert_assignment (REF (exp, SEQ, TAIL), assigned)); case SCM_EXPANDED_LAMBDA: return LAMBDA - (REF (exp, LAMBDA, SRC), - REF (exp, LAMBDA, META), + (REF (exp, LAMBDA, META), scm_is_false (REF (exp, LAMBDA, BODY)) /* Give a body to case-lambda with no clauses. */ - ? LAMBDA_CASE (SCM_BOOL_F, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F, + ? LAMBDA_CASE (SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F, SCM_EOL, SCM_EOL, PRIMCALL - (SCM_BOOL_F, - scm_from_latin1_symbol ("throw"), - scm_list_5 (CONST_ (SCM_BOOL_F, scm_args_number_key), - CONST_ (SCM_BOOL_F, SCM_BOOL_F), - CONST_ (SCM_BOOL_F, scm_from_latin1_string + (scm_from_latin1_symbol ("throw"), + scm_list_5 (CONST_ (scm_args_number_key), + CONST_ (SCM_BOOL_F), + CONST_ (scm_from_latin1_string ("Wrong number of arguments")), - CONST_ (SCM_BOOL_F, SCM_EOL), - CONST_ (SCM_BOOL_F, SCM_BOOL_F))), + CONST_ (SCM_EOL), + CONST_ (SCM_BOOL_F))), SCM_BOOL_F) : convert_assignment (REF (exp, LAMBDA, BODY), assigned)); case SCM_EXPANDED_LAMBDA_CASE: { - SCM src, req, opt, rest, kw, inits, syms, body, alt; + SCM 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); @@ -1470,7 +1379,7 @@ convert_assignment (SCM exp, SCM assigned) inits = CDR (inits)) { SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (inits); - seq = scm_cons (init_if_unbound (src, name, sym, init), seq); + seq = scm_cons (init_if_unbound (name, sym, init), seq); if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F))) seq = scm_cons (box_lexical (name, sym), seq); } @@ -1489,23 +1398,22 @@ convert_assignment (SCM exp, SCM assigned) 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); + seq = scm_cons (init_if_unbound (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); + body = SEQ (CAR (seq), body); return LAMBDA_CASE - (src, req, opt, rest, kw, new_inits, syms, body, alt); + (req, opt, rest, kw, new_inits, syms, body, alt); } case SCM_EXPANDED_LET: { - SCM src, names, syms, vals, body, new_vals, walk; + SCM 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); @@ -1523,28 +1431,26 @@ convert_assignment (SCM exp, SCM assigned) } new_vals = scm_reverse (new_vals); - return LET (src, names, syms, new_vals, body); + return LET (names, syms, new_vals, body); } case SCM_EXPANDED_LETREC: { - SCM src, names, syms, vals, empty_box, boxes, body; + SCM 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"), + PRIMCALL (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, + (names, syms, boxes, init_boxes (names, syms, vals, body)); else { @@ -1554,17 +1460,16 @@ convert_assignment (SCM exp, SCM assigned) { SCM tmp = scm_gensym (SCM_UNDEFINED); tmps = scm_cons (tmp, tmps); - inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, SCM_BOOL_F, tmp), + inits = scm_cons (LEXICAL_REF (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))), + (names, syms, boxes, + SEQ (LET (names, tmps, vals, + init_boxes (names, syms, inits, VOID_ ())), body)); } } @@ -1654,7 +1559,7 @@ scm_init_expand () 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"))); + CONST_ (scm_list_1 (scm_from_latin1_symbol ("unbound"))); scm_c_define_gsubr ("convert-assignment", 1, 0, 0, scm_convert_assignment); |