diff options
Diffstat (limited to 'libguile/expand.c')
-rw-r--r-- | libguile/expand.c | 102 |
1 files changed, 41 insertions, 61 deletions
diff --git a/libguile/expand.c b/libguile/expand.c index cae552086..7d6a6ed32 100644 --- a/libguile/expand.c +++ b/libguile/expand.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2012 +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2012,2013 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -56,8 +56,8 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES]; SCM_MAKE_EXPANDED_VOID(src) #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) \ @@ -74,10 +74,12 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES]; SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp) #define CONDITIONAL(src, test, consequent, alternate) \ SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate) -#define APPLICATION(src, proc, exps) \ - SCM_MAKE_EXPANDED_APPLICATION(src, proc, exps) -#define SEQUENCE(src, exps) \ - SCM_MAKE_EXPANDED_SEQUENCE(src, exps) +#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) \ @@ -86,8 +88,6 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES]; 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) @@ -153,7 +153,6 @@ SCM_SYNTAX ("@", expand_at); 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); @@ -174,19 +173,13 @@ SCM_SYNTAX ("case-lambda", expand_case_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"); @@ -195,12 +188,13 @@ SCM_GLOBAL_SYMBOL (scm_sym_let, "let"); 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"); @@ -356,17 +350,22 @@ expand (SCM exp, SCM env) { 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 APPLICATION (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)) @@ -399,7 +398,9 @@ expand_sequence (const SCM forms, const SCM env) if (scm_is_null (CDR (forms))) return expand (CAR (forms), env); else - return SEQUENCE (SCM_BOOL_F, expand_exprs (forms, env)); + return SEQ (scm_source_properties (forms), + expand (CAR (forms), env), + expand_sequence (CDR (forms), env)); } @@ -421,9 +422,12 @@ 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); } @@ -490,10 +494,10 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env) scm_list_1 (expand (test, env)), CONDITIONAL (SCM_BOOL_F, LEXICAL_REF (SCM_BOOL_F, tmp, tmp), - APPLICATION (SCM_BOOL_F, - expand (CADDR (clause), new_env), - scm_list_1 (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))), rest)); } /* FIXME length == 1 case */ @@ -556,30 +560,6 @@ expand_define (SCM expr, SCM 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) { ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr); @@ -996,9 +976,9 @@ expand_named_let (const SCM expr, SCM env) SCM_BOOL_F, SCM_BOOL_F, var_syms, expand_sequence (CDDDR (expr), inner_env), SCM_BOOL_F))), - APPLICATION (SCM_BOOL_F, - LEXICAL_REF (SCM_BOOL_F, name, name_sym), - expand_exprs (inits, env))); + CALL (SCM_BOOL_F, + LEXICAL_REF (SCM_BOOL_F, name, name_sym), + expand_exprs (inits, env))); } static SCM @@ -1215,13 +1195,13 @@ make_exp_vtable (size_t n) (scm_string_append (scm_make_list (scm_from_size_t (exp_nfields[n]), scm_from_locale_string ("pw")))); printer = SCM_BOOL_F; - name = scm_from_locale_symbol (exp_names[n]); + name = scm_from_utf8_symbol (exp_names[n]); code = scm_from_size_t (n); fields = SCM_EOL; { size_t m = exp_nfields[n]; while (m--) - fields = scm_cons (scm_from_locale_symbol (exp_field_names[n][m]), fields); + fields = scm_cons (scm_from_utf8_symbol (exp_field_names[n][m]), fields); } return scm_c_make_struct (scm_exp_vtable_vtable, 0, 5, @@ -1246,13 +1226,13 @@ scm_init_expand () DEFINE_NAMES (TOPLEVEL_SET); DEFINE_NAMES (TOPLEVEL_DEFINE); DEFINE_NAMES (CONDITIONAL); - DEFINE_NAMES (APPLICATION); - DEFINE_NAMES (SEQUENCE); + DEFINE_NAMES (CALL); + DEFINE_NAMES (PRIMCALL); + DEFINE_NAMES (SEQ); DEFINE_NAMES (LAMBDA); 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"), |