summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/Makefile.am4
-rw-r--r--libguile/eval.c39
-rw-r--r--libguile/expand.c1253
-rw-r--r--libguile/expand.h346
-rw-r--r--libguile/init.c2
-rw-r--r--libguile/memoize.c1270
-rw-r--r--module/ice-9/eval.scm10
7 files changed, 1842 insertions, 1082 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index a841c9fe3..90d8b61d3 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -127,6 +127,7 @@ libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES = \
error.c \
eval.c \
evalext.c \
+ expand.c \
extensions.c \
feature.c \
fluids.c \
@@ -229,6 +230,7 @@ DOT_X_FILES = \
error.x \
eval.x \
evalext.x \
+ expand.x \
extensions.x \
feature.x \
fluids.x \
@@ -328,6 +330,7 @@ DOT_DOC_FILES = \
error.doc \
eval.doc \
evalext.doc \
+ expand.doc \
extensions.doc \
feature.doc \
fluids.doc \
@@ -487,6 +490,7 @@ modinclude_HEADERS = \
error.h \
eval.h \
evalext.h \
+ expand.h \
extensions.h \
feature.h \
filesys.h \
diff --git a/libguile/eval.c b/libguile/eval.c
index 7c2106023..63808c62d 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -114,15 +114,26 @@ static scm_t_bits scm_tc16_boot_closure;
#define BOOT_CLOSURE_IS_REST(x) scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x)))
/* NB: One may only call the following accessors if the closure is not REST. */
#define BOOT_CLOSURE_IS_FULL(x) (1)
-#define BOOT_CLOSURE_PARSE_FULL(x,body,nargs,rest,nopt,kw,inits,alt) \
- do { SCM mx = BOOT_CLOSURE_CODE (x); \
- body = CAR (mx); mx = CDR (mx); \
- nreq = SCM_I_INUM (CAR (mx)); mx = CDR (mx); \
- rest = CAR (mx); mx = CDR (mx); \
- nopt = SCM_I_INUM (CAR (mx)); mx = CDR (mx); \
- kw = CAR (mx); mx = CDR (mx); \
- inits = CAR (mx); mx = CDR (mx); \
- alt = CAR (mx); \
+#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \
+ do { SCM fu = fu_; \
+ body = CAR (fu); fu = CDR (fu); \
+ \
+ rest = kw = alt = SCM_BOOL_F; \
+ inits = SCM_EOL; \
+ nopt = 0; \
+ \
+ nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
+ if (scm_is_pair (fu)) \
+ { \
+ rest = CAR (fu); fu = CDR (fu); \
+ if (scm_is_pair (fu)) \
+ { \
+ nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
+ kw = CAR (fu); fu = CDR (fu); \
+ inits = CAR (fu); fu = CDR (fu); \
+ alt = CAR (fu); \
+ } \
+ } \
} while (0)
static void prepare_boot_closure_env_for_apply (SCM proc, SCM args,
SCM *out_body, SCM *out_env);
@@ -906,6 +917,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
{
int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc);
SCM env = BOOT_CLOSURE_ENV (proc);
+
if (BOOT_CLOSURE_IS_FIXED (proc)
|| (BOOT_CLOSURE_IS_REST (proc)
&& !BOOT_CLOSURE_HAS_REST_ARGS (proc)))
@@ -931,16 +943,17 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
{
int i, argc, nreq, nopt;
SCM body, rest, kw, inits, alt;
+ SCM mx = BOOT_CLOSURE_CODE (proc);
loop:
- BOOT_CLOSURE_PARSE_FULL (proc, body, nargs, rest, nopt, kw, inits, alt);
+ BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, inits, alt);
argc = scm_ilength (args);
if (argc < nreq)
{
if (scm_is_true (alt))
{
- proc = alt;
+ mx = alt;
goto loop;
}
else
@@ -950,7 +963,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
{
if (scm_is_true (alt))
{
- proc = alt;
+ mx = alt;
goto loop;
}
else
@@ -1048,7 +1061,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args,
}
}
- *out_body = BOOT_CLOSURE_BODY (proc);
+ *out_body = body;
*out_env = env;
}
}
diff --git a/libguile/expand.c b/libguile/expand.c
new file mode 100644
index 000000000..e122496c8
--- /dev/null
+++ b/libguile/expand.c
@@ -0,0 +1,1253 @@
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010
+ * Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/__scm.h"
+#include "libguile/_scm.h"
+#include "libguile/continuations.h"
+#include "libguile/eq.h"
+#include "libguile/list.h"
+#include "libguile/macros.h"
+#include "libguile/expand.h"
+#include "libguile/modules.h"
+#include "libguile/srcprop.h"
+#include "libguile/ports.h"
+#include "libguile/print.h"
+#include "libguile/strings.h"
+#include "libguile/throw.h"
+#include "libguile/validate.h"
+
+
+
+
+
+SCM scm_exp_vtable_vtable;
+static SCM exp_vtables[SCM_NUM_EXPANDED_TYPES];
+static size_t exp_nfields[SCM_NUM_EXPANDED_TYPES];
+static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
+static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
+
+
+#define VOID(src) \
+ 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 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, name) \
+ SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name)
+#define TOPLEVEL_SET(src, name, exp) \
+ SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp)
+#define TOPLEVEL_DEFINE(src, name, exp) \
+ 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 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, names, gensyms, vals, body) \
+ SCM_MAKE_EXPANDED_LETREC(src, 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 CAAR(x) SCM_CAAR(x)
+#define CADR(x) SCM_CADR(x)
+#define CDAR(x) SCM_CDAR(x)
+#define CDDR(x) SCM_CDDR(x)
+#define CADDR(x) SCM_CADDR(x)
+#define CDDDR(x) SCM_CDDDR(x)
+#define CADDDR(x) SCM_CADDDR(x)
+
+
+static const char s_bad_expression[] = "Bad expression";
+static const char s_expression[] = "Missing or extra expression in";
+static const char s_missing_expression[] = "Missing expression in";
+static const char s_extra_expression[] = "Extra expression in";
+static const char s_empty_combination[] = "Illegal empty combination";
+static const char s_missing_body_expression[] = "Missing body expression in";
+static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
+static const char s_bad_define[] = "Bad define placement";
+static const char s_missing_clauses[] = "Missing clauses";
+static const char s_misplaced_else_clause[] = "Misplaced else clause";
+static const char s_bad_case_clause[] = "Bad case clause";
+static const char s_bad_case_labels[] = "Bad case labels";
+static const char s_duplicate_case_label[] = "Duplicate case label";
+static const char s_bad_cond_clause[] = "Bad cond clause";
+static const char s_missing_recipient[] = "Missing recipient in";
+static const char s_bad_variable[] = "Bad variable";
+static const char s_bad_bindings[] = "Bad bindings";
+static const char s_bad_binding[] = "Bad binding";
+static const char s_duplicate_binding[] = "Duplicate binding";
+static const char s_bad_exit_clause[] = "Bad exit clause";
+static const char s_bad_formals[] = "Bad formals";
+static const char s_bad_formal[] = "Bad formal";
+static const char s_duplicate_formal[] = "Duplicate formal";
+static const char s_splicing[] = "Non-list result for unquote-splicing";
+static const char s_bad_slot_number[] = "Bad slot number";
+
+static void syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
+
+SCM_SYMBOL (syntax_error_key, "syntax-error");
+
+/* Shortcut macros to simplify syntax error handling. */
+#define ASSERT_SYNTAX(cond, message, form) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, SCM_UNDEFINED); }
+#define ASSERT_SYNTAX_2(cond, message, form, expr) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, expr); }
+
+
+
+
+/* Primitive syntax. */
+
+#define SCM_SYNTAX(STR, CFN) \
+SCM_SNARF_HERE(static SCM CFN (SCM xorig, SCM env)) \
+SCM_SNARF_INIT(scm_c_define (STR, scm_i_make_primitive_macro (STR, CFN)))
+
+
+/* True primitive syntax */
+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);
+SCM_SYNTAX ("let", expand_let);
+SCM_SYNTAX ("quote", expand_quote);
+SCM_SYNTAX ("set!", expand_set_x);
+
+/* Convenient syntax during boot, expands to primitive syntax. Replaced after
+ psyntax boots. */
+SCM_SYNTAX ("and", expand_and);
+SCM_SYNTAX ("cond", expand_cond);
+SCM_SYNTAX ("letrec", expand_letrec);
+SCM_SYNTAX ("let*", expand_letstar);
+SCM_SYNTAX ("or", expand_or);
+SCM_SYNTAX ("lambda*", expand_lambda_star);
+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");
+SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
+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_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_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
+SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
+SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
+
+SCM_KEYWORD (kw_allow_other_keys, "allow-other-keys");
+SCM_KEYWORD (kw_optional, "optional");
+SCM_KEYWORD (kw_key, "key");
+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_locale_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);
+ }
+ }
+ 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);
+ }
+ }
+
+ scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
+}
+
+
+
+
+
+static int
+expand_env_var_is_free (SCM env, SCM x)
+{
+ for (; scm_is_pair (env); env = CDR (env))
+ if (scm_is_eq (x, CAAR (env)))
+ return 0; /* bound */
+ return 1; /* free */
+}
+
+static SCM
+expand_env_ref_macro (SCM env, SCM x)
+{
+ SCM var;
+ if (!expand_env_var_is_free (env, x))
+ return SCM_BOOL_F; /* lexical */
+
+ var = scm_module_variable (scm_current_module (), x);
+ if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
+ && scm_is_true (scm_macro_p (scm_variable_ref (var))))
+ return scm_variable_ref (var);
+ else
+ return SCM_BOOL_F; /* anything else */
+}
+
+static SCM
+expand_env_lexical_gensym (SCM env, SCM name)
+{
+ for (; scm_is_pair (env); env = CDR (env))
+ if (scm_is_eq (name, CAAR (env)))
+ return CDAR (env); /* bound */
+ return SCM_BOOL_F; /* free */
+}
+
+static SCM
+expand_env_extend (SCM env, SCM names, SCM vars)
+{
+ while (scm_is_pair (names))
+ {
+ env = scm_acons (CAR (names), CAR (vars), env);
+ names = CDR (names);
+ vars = CDR (vars);
+ }
+ return env;
+}
+
+static SCM
+expand (SCM exp, SCM env)
+{
+ if (scm_is_pair (exp))
+ {
+ SCM car;
+ scm_t_macro_primitive trans = NULL;
+ SCM macro = SCM_BOOL_F;
+
+ car = CAR (exp);
+ if (scm_is_symbol (car))
+ macro = expand_env_ref_macro (env, car);
+
+ if (scm_is_true (macro))
+ trans = scm_i_macro_primitive (macro);
+
+ if (trans)
+ return trans (exp, env);
+ else
+ {
+ SCM arg_exps = SCM_EOL;
+ SCM args = SCM_EOL;
+ SCM proc = CAR (exp);
+
+ 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
+ syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
+ }
+ }
+ 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);
+ else
+ return TOPLEVEL_REF (SCM_BOOL_F, exp);
+ }
+ else
+ return CONST (SCM_BOOL_F, exp);
+}
+
+static SCM
+expand_exprs (SCM forms, const SCM env)
+{
+ SCM ret = SCM_EOL;
+
+ for (; !scm_is_null (forms); forms = CDR (forms))
+ ret = scm_cons (expand (CAR (forms), env), ret);
+ return scm_reverse_x (ret, SCM_UNDEFINED);
+}
+
+static SCM
+expand_sequence (const SCM forms, const SCM env)
+{
+ ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
+ scm_cons (scm_sym_begin, forms));
+ if (scm_is_null (CDR (forms)))
+ return expand (CAR (forms), env);
+ else
+ return SEQUENCE (SCM_BOOL_F, expand_exprs (forms, env));
+}
+
+
+
+
+
+static SCM
+expand_at (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);
+
+ return MODULE_REF (scm_source_properties (expr),
+ CADR (expr), CADDR (expr), SCM_BOOL_T);
+}
+
+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);
+
+ return MODULE_REF (scm_source_properties (expr),
+ CADR (expr), CADDR (expr), SCM_BOOL_F);
+}
+
+static SCM
+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);
+
+ 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),
+ expand_and (cdr_expr, env),
+ CONST (SCM_BOOL_F, SCM_BOOL_F));
+}
+
+static SCM
+expand_begin (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr);
+ return expand_sequence (cdr_expr, env);
+}
+
+static SCM
+expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
+{
+ SCM test;
+ const long length = scm_ilength (clause);
+ ASSERT_SYNTAX (length >= 1, s_bad_cond_clause, clause);
+
+ test = CAR (clause);
+ if (scm_is_eq (test, scm_sym_else) && elp)
+ {
+ const int last_clause_p = scm_is_null (rest);
+ ASSERT_SYNTAX (length >= 2, s_bad_cond_clause, clause);
+ ASSERT_SYNTAX (last_clause_p, s_misplaced_else_clause, clause);
+ return expand_sequence (CDR (clause), env);
+ }
+
+ if (scm_is_null (rest))
+ rest = VOID (SCM_BOOL_F);
+ else
+ rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
+
+ if (length >= 2
+ && scm_is_eq (CADR (clause), scm_sym_arrow)
+ && alp)
+ {
+ SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
+ 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),
+ scm_list_1 (tmp),
+ 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))),
+ rest));
+ }
+ /* FIXME length == 1 case */
+ else
+ return CONDITIONAL (SCM_BOOL_F,
+ expand (test, env),
+ expand_sequence (CDR (clause), env),
+ rest);
+}
+
+static SCM
+expand_cond (SCM expr, SCM env)
+{
+ const int else_literal_p = expand_env_var_is_free (env, scm_sym_else);
+ const int arrow_literal_p = expand_env_var_is_free (env, scm_sym_arrow);
+ const SCM clauses = CDR (expr);
+
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
+
+ return expand_cond_clauses (CAR (clauses), CDR (clauses),
+ else_literal_p, arrow_literal_p, env);
+}
+
+/* lone forward decl */
+static SCM expand_lambda (SCM expr, SCM env);
+
+/* According to Section 5.2.1 of R5RS we first have to make sure that the
+ variable is bound, and then perform the `(set! variable expression)'
+ operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
+ bound. This means that EXPRESSION won't necessarily be able to assign
+ values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
+static SCM
+expand_define (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ SCM body;
+ SCM variable;
+
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+ ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);
+
+ body = CDR (cdr_expr);
+ variable = CAR (cdr_expr);
+
+ if (scm_is_pair (variable))
+ {
+ ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
+ return TOPLEVEL_DEFINE
+ (scm_source_properties (expr),
+ 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), variable,
+ 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)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
+
+ if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
+ || scm_is_true (scm_memq (sym_load, CADR (expr))))
+ return expand_sequence (CDDR (expr), env);
+ else
+ return VOID (scm_source_properties (expr));
+}
+
+static SCM
+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),
+ expand (CADDR (expr), env),
+ ((length == 3)
+ ? expand (CADDDR (expr), env)
+ : VOID (SCM_BOOL_F)));
+}
+
+/* A helper function for expand_lambda to support checking for duplicate
+ * formal arguments: Return true if OBJ is `eq?' to one of the elements of
+ * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
+ * forms that a formal argument can have:
+ * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
+static int
+c_improper_memq (SCM obj, SCM list)
+{
+ for (; scm_is_pair (list); list = CDR (list))
+ {
+ if (scm_is_eq (CAR (list), obj))
+ return 1;
+ }
+ return scm_is_eq (list, obj);
+}
+
+static SCM
+expand_lambda_case (SCM clause, SCM alternate, SCM env)
+{
+ SCM formals;
+ SCM rest;
+ SCM req = SCM_EOL;
+ SCM vars = SCM_EOL;
+ SCM body;
+ int nreq = 0;
+
+ ASSERT_SYNTAX (scm_is_pair (clause) && scm_is_pair (CDR (clause)),
+ s_bad_expression, scm_cons (scm_sym_lambda, clause));
+
+ /* Before iterating the list of formal arguments, make sure the formals
+ * actually are given as either a symbol or a non-cyclic list. */
+ formals = CAR (clause);
+ if (scm_is_pair (formals))
+ {
+ /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
+ * detected, report a 'Bad formals' error. */
+ }
+ else
+ ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
+ s_bad_formals, formals, scm_cons (scm_sym_lambda, clause));
+
+ /* Now iterate the list of formal arguments to check if all formals are
+ * symbols, and that there are no duplicates. */
+ while (scm_is_pair (formals))
+ {
+ const SCM formal = CAR (formals);
+ formals = CDR (formals);
+ ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal,
+ scm_cons (scm_sym_lambda, clause));
+ ASSERT_SYNTAX_2 (!c_improper_memq (formal, formals), s_duplicate_formal,
+ formal, scm_cons (scm_sym_lambda, clause));
+ nreq++;
+ req = scm_cons (formal, req);
+ vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
+ env = scm_acons (formal, CAR (vars), env);
+ }
+
+ ASSERT_SYNTAX_2 (scm_is_null (formals) || scm_is_symbol (formals),
+ s_bad_formal, formals, scm_cons (scm_sym_lambda, clause));
+ if (scm_is_symbol (formals))
+ {
+ rest = formals;
+ vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
+ env = scm_acons (rest, CAR (vars), env);
+ }
+ else
+ rest = SCM_BOOL_F;
+
+ body = expand_sequence (CDR (clause), env);
+ req = scm_reverse_x (req, SCM_UNDEFINED);
+ vars = scm_reverse_x (vars, SCM_UNDEFINED);
+
+ 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,
+ SCM_EOL, vars, body, alternate);
+}
+
+static SCM
+expand_lambda (SCM expr, SCM env)
+{
+ return LAMBDA (scm_source_properties (expr),
+ SCM_EOL,
+ expand_lambda_case (CDR (expr), SCM_BOOL_F, env));
+}
+
+static SCM
+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;
+ int nreq, nopt;
+
+ const long length = scm_ilength (clause);
+ ASSERT_SYNTAX (length >= 1, s_bad_expression,
+ scm_cons (sym_lambda_star, clause));
+ ASSERT_SYNTAX (length >= 2, s_missing_expression,
+ scm_cons (sym_lambda_star, clause));
+
+ formals = CAR (clause);
+ body = CDR (clause);
+
+ nreq = nopt = 0;
+ req = opt = kw = SCM_EOL;
+ rest = allow_other_keys = SCM_BOOL_F;
+
+ while (scm_is_pair (formals) && scm_is_symbol (CAR (formals)))
+ {
+ nreq++;
+ req = scm_cons (CAR (formals), req);
+ formals = scm_cdr (formals);
+ }
+
+ if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_optional))
+ {
+ formals = CDR (formals);
+ while (scm_is_pair (formals)
+ && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
+ {
+ nopt++;
+ opt = scm_cons (CAR (formals), opt);
+ formals = scm_cdr (formals);
+ }
+ }
+
+ if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_key))
+ {
+ formals = CDR (formals);
+ while (scm_is_pair (formals)
+ && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
+ {
+ kw = scm_cons (CAR (formals), kw);
+ formals = scm_cdr (formals);
+ }
+ }
+
+ if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_allow_other_keys))
+ {
+ formals = CDR (formals);
+ allow_other_keys = SCM_BOOL_T;
+ }
+
+ if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_rest))
+ {
+ ASSERT_SYNTAX (scm_ilength (formals) == 2, s_bad_formals,
+ CAR (clause));
+ rest = CADR (formals);
+ }
+ else if (scm_is_symbol (formals))
+ rest = formals;
+ else
+ {
+ ASSERT_SYNTAX (scm_is_null (formals), s_bad_formals, CAR (clause));
+ rest = SCM_BOOL_F;
+ }
+
+ /* Now, iterate through them a second time, building up an expansion-time
+ environment, checking, expanding and canonicalizing the opt/kw init forms,
+ and eventually memoizing the body as well. Note that the rest argument, if
+ any, is expanded before keyword args, thus necessitating the second
+ pass.
+
+ Also note that the specific environment during expansion of init
+ expressions here needs to coincide with the environment when psyntax
+ expands. A lot of effort for something that is only used in the bootstrap
+ expandr, you say? Yes. Yes it is.
+ */
+
+ vars = SCM_EOL;
+ req = scm_reverse_x (req, SCM_EOL);
+ for (tmp = req; scm_is_pair (tmp); tmp = scm_cdr (tmp))
+ {
+ vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
+ env = scm_acons (CAR (tmp), CAR (vars), env);
+ }
+
+ /* Build up opt inits and env */
+ inits = SCM_EOL;
+ opt = scm_reverse_x (opt, SCM_EOL);
+ for (tmp = opt; scm_is_pair (tmp); tmp = scm_cdr (tmp))
+ {
+ SCM x = CAR (tmp);
+ 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);
+ else
+ {
+ ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
+ s_bad_formals, CAR (clause));
+ inits = scm_cons (expand (CADR (x), env), inits);
+ }
+ env = scm_acons (scm_is_symbol (x) ? x : CAR (x), CAR (vars), env);
+ }
+ if (scm_is_null (opt))
+ opt = SCM_BOOL_F;
+
+ /* Process rest before keyword args */
+ if (scm_is_true (rest))
+ {
+ vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
+ env = scm_acons (rest, CAR (vars), env);
+ }
+
+ /* Build up kw inits, env, and kw-indices alist */
+ if (scm_is_null (kw))
+ kw = SCM_BOOL_F;
+ else
+ {
+ int idx = nreq + nopt + (scm_is_true (rest) ? 1 : 0);
+
+ kw_indices = SCM_EOL;
+ kw = scm_reverse_x (kw, SCM_UNDEFINED);
+ for (tmp = kw; scm_is_pair (tmp); tmp = scm_cdr (tmp))
+ {
+ SCM x, sym, k, init;
+ x = CAR (tmp);
+ if (scm_is_symbol (x))
+ {
+ sym = x;
+ init = SCM_BOOL_F;
+ k = scm_symbol_to_keyword (sym);
+ }
+ else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
+ {
+ sym = CAR (x);
+ init = CADR (x);
+ k = scm_symbol_to_keyword (sym);
+ }
+ else if (scm_ilength (x) == 3 && scm_is_symbol (CAR (x))
+ && scm_is_keyword (CADDR (x)))
+ {
+ sym = CAR (x);
+ init = CADR (x);
+ k = CADDR (x);
+ }
+ 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);
+ env = scm_acons (sym, CAR (vars), env);
+ }
+ kw_indices = scm_reverse_x (kw_indices, SCM_UNDEFINED);
+ kw = scm_cons (allow_other_keys, kw_indices);
+ }
+
+ /* We should check for no duplicates, but given that psyntax does this
+ already, we can punt on it here... */
+
+ vars = scm_reverse_x (vars, SCM_UNDEFINED);
+ 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,
+ alternate);
+}
+
+static SCM
+expand_lambda_star (SCM expr, SCM env)
+{
+ return LAMBDA (scm_source_properties (expr),
+ SCM_EOL,
+ expand_lambda_star_case (CDR (expr), SCM_BOOL_F, env));
+}
+
+static SCM
+expand_case_lambda_clauses (SCM expr, SCM rest, SCM env)
+{
+ SCM alt;
+
+ if (scm_is_pair (rest))
+ alt = expand_case_lambda_clauses (CAR (rest), CDR (rest), env);
+ else
+ alt = SCM_BOOL_F;
+
+ return expand_lambda_case (expr, alt, env);
+}
+
+static SCM
+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,
+ expand_case_lambda_clauses (CADR (expr), CDDR (expr), env));
+}
+
+static SCM
+expand_case_lambda_star_clauses (SCM expr, SCM rest, SCM env)
+{
+ SCM alt;
+
+ if (scm_is_pair (rest))
+ alt = expand_case_lambda_star_clauses (CAR (rest), CDR (rest), env);
+ else
+ alt = SCM_BOOL_F;
+
+ return expand_lambda_star_case (expr, alt, env);
+}
+
+static SCM
+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,
+ expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env));
+}
+
+/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
+static void
+check_bindings (const SCM bindings, const SCM expr)
+{
+ SCM binding_idx;
+
+ ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
+ s_bad_bindings, bindings, expr);
+
+ binding_idx = bindings;
+ for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
+ {
+ SCM name; /* const */
+
+ const SCM binding = CAR (binding_idx);
+ ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
+ s_bad_binding, binding, expr);
+
+ name = CAR (binding);
+ ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
+ }
+}
+
+/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
+ * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
+ * variable name is detected, an error is signalled. */
+static void
+transform_bindings (const SCM bindings, const SCM expr,
+ SCM *const names, SCM *const vars, SCM *const initptr)
+{
+ SCM rnames = SCM_EOL;
+ SCM rvars = SCM_EOL;
+ SCM rinits = SCM_EOL;
+ SCM binding_idx = bindings;
+ for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
+ {
+ const SCM binding = CAR (binding_idx);
+ const SCM CDR_binding = CDR (binding);
+ const SCM name = CAR (binding);
+ ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rnames)),
+ s_duplicate_binding, name, expr);
+ rnames = scm_cons (name, rnames);
+ rvars = scm_cons (scm_gensym (SCM_UNDEFINED), rvars);
+ rinits = scm_cons (CAR (CDR_binding), rinits);
+ }
+ *names = scm_reverse_x (rnames, SCM_UNDEFINED);
+ *vars = scm_reverse_x (rvars, SCM_UNDEFINED);
+ *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
+}
+
+/* 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_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))),
+ APPLICATION (SCM_BOOL_F,
+ LEXICAL_REF (SCM_BOOL_F, name, name_sym),
+ expand_exprs (inits, env)));
+}
+
+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)));
+ }
+}
+
+static SCM
+expand_letrec (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);
+ 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);
+ env = expand_env_extend (env, var_names, var_syms);
+ return LETREC (SCM_BOOL_F,
+ var_names, var_syms, expand_exprs (inits, env),
+ expand_sequence (CDDR (expr), env));
+ }
+}
+
+static SCM
+expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
+{
+ if (scm_is_null (bindings))
+ return expand_sequence (body, env);
+ else
+ {
+ SCM bind, name, sym, init;
+
+ ASSERT_SYNTAX (scm_is_pair (bindings), s_bad_expression, bindings);
+ bind = CAR (bindings);
+ ASSERT_SYNTAX (scm_ilength (bind) == 2, s_bad_binding, bind);
+ name = CAR (bind);
+ sym = scm_gensym (SCM_UNDEFINED);
+ init = CADR (bind);
+
+ return LET (SCM_BOOL_F, 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)));
+ }
+}
+
+static SCM
+expand_letstar (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ return expand_letstar_clause (CADR (expr), CDDR (expr), env);
+}
+
+static SCM
+expand_or (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM tail = CDR (expr);
+ const long length = scm_ilength (tail);
+
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+
+ if (scm_is_null (CDR (expr)))
+ return CONST (SCM_BOOL_F, SCM_BOOL_F);
+ else
+ {
+ SCM tmp = scm_gensym (SCM_UNDEFINED);
+ return LET (SCM_BOOL_F,
+ 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),
+ expand_or (CDR (expr),
+ scm_acons (tmp, tmp, env))));
+ }
+}
+
+static SCM
+expand_quote (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM quotee;
+
+ const SCM cdr_expr = CDR (expr);
+ 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);
+}
+
+static SCM
+expand_set_x (SCM expr, SCM env)
+{
+ SCM variable;
+ SCM vmem;
+
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+ variable = CAR (cdr_expr);
+ vmem = expand (variable, 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),
+ 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, NAME),
+ expand (CADDR (expr), env));
+ case SCM_EXPANDED_MODULE_REF:
+ return MODULE_SET (scm_source_properties (expr),
+ 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));
+ default:
+ syntax_error (s_bad_variable, variable, expr);
+ }
+}
+
+
+
+
+SCM_DEFINE (scm_macroexpand, "macroexpand*", 1, 0, 0,
+ (SCM exp),
+ "Expand the expression @var{exp}.")
+#define FUNC_NAME s_scm_macroexpand
+{
+ return expand (exp, scm_current_module ());
+}
+#undef FUNC_NAME
+
+
+
+
+#define DEFINE_NAMES(type) \
+ { \
+ static const char *fields[] = SCM_EXPANDED_##type##_FIELD_NAMES; \
+ exp_field_names[SCM_EXPANDED_##type] = fields; \
+ exp_names[SCM_EXPANDED_##type] = SCM_EXPANDED_##type##_TYPE_NAME; \
+ exp_nfields[SCM_EXPANDED_##type] = SCM_NUM_EXPANDED_##type##_FIELDS; \
+ }
+
+static SCM
+make_exp_vtable (size_t n)
+{
+ SCM layout, printer, name, code, fields;
+
+ layout = scm_string_to_symbol
+ (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]);
+ 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);
+ }
+
+ return scm_c_make_struct (scm_exp_vtable_vtable, 0, 5,
+ SCM_UNPACK (layout), SCM_UNPACK (printer), SCM_UNPACK (name),
+ SCM_UNPACK (code), SCM_UNPACK (fields));
+}
+
+void
+scm_init_expand ()
+{
+ size_t n;
+ SCM exp_vtable_list = SCM_EOL;
+
+ DEFINE_NAMES (VOID);
+ DEFINE_NAMES (CONST);
+ DEFINE_NAMES (PRIMITIVE_REF);
+ DEFINE_NAMES (LEXICAL_REF);
+ DEFINE_NAMES (LEXICAL_SET);
+ DEFINE_NAMES (MODULE_REF);
+ DEFINE_NAMES (MODULE_SET);
+ DEFINE_NAMES (TOPLEVEL_REF);
+ DEFINE_NAMES (TOPLEVEL_SET);
+ DEFINE_NAMES (TOPLEVEL_DEFINE);
+ DEFINE_NAMES (CONDITIONAL);
+ DEFINE_NAMES (APPLICATION);
+ DEFINE_NAMES (SEQUENCE);
+ 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"),
+ SCM_BOOL_F);
+
+ for (n = 0; n < SCM_NUM_EXPANDED_TYPES; n++)
+ exp_vtables[n] = make_exp_vtable (n);
+
+ /* Now walk back down, consing in reverse. */
+ while (n--)
+ exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list);
+
+ scm_c_define ("%expanded-vtables", exp_vtable_list);
+
+#include "libguile/expand.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/expand.h b/libguile/expand.h
new file mode 100644
index 000000000..d57e2030f
--- /dev/null
+++ b/libguile/expand.h
@@ -0,0 +1,346 @@
+/* classes: h_files */
+
+#ifndef SCM_EXPAND_H
+#define SCM_EXPAND_H
+
+/* Copyright (C) 2010
+ * Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+
+
+
+
+#ifdef BUILDING_LIBGUILE
+
+/* All private for now. Ask if you want to use this. Surely this should be
+ auto-generated by something; for now I wrangle it with keyboard macros. */
+
+typedef enum
+ {
+ SCM_EXPANDED_VOID,
+ SCM_EXPANDED_CONST,
+ SCM_EXPANDED_PRIMITIVE_REF,
+ SCM_EXPANDED_LEXICAL_REF,
+ SCM_EXPANDED_LEXICAL_SET,
+ SCM_EXPANDED_MODULE_REF,
+ SCM_EXPANDED_MODULE_SET,
+ SCM_EXPANDED_TOPLEVEL_REF,
+ SCM_EXPANDED_TOPLEVEL_SET,
+ SCM_EXPANDED_TOPLEVEL_DEFINE,
+ SCM_EXPANDED_CONDITIONAL,
+ SCM_EXPANDED_APPLICATION,
+ SCM_EXPANDED_SEQUENCE,
+ SCM_EXPANDED_LAMBDA,
+ SCM_EXPANDED_LAMBDA_CASE,
+ SCM_EXPANDED_LET,
+ SCM_EXPANDED_LETREC,
+ SCM_EXPANDED_DYNLET,
+ SCM_NUM_EXPANDED_TYPES,
+ } scm_t_expanded_type;
+
+
+
+
+
+/* {Expanded Source}
+ */
+
+SCM_INTERNAL SCM scm_exp_vtable_vtable;
+
+enum
+ {
+ SCM_EXPANDED_TYPE_NAME = scm_vtable_offset_user,
+ SCM_EXPANDED_TYPE_CODE,
+ SCM_EXPANDED_TYPE_FIELDS,
+ };
+
+#define SCM_EXPANDED_P(x) \
+ (SCM_STRUCTP (x) && (SCM_STRUCT_VTABLE (SCM_STRUCT_VTABLE (x)) == scm_exp_vtable_vtable))
+#define SCM_EXPANDED_REF(x,type,field) \
+ (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
+#define SCM_EXPANDED_TYPE(x) \
+ SCM_STRUCT_DATA_REF (SCM_STRUCT_VTABLE (x), SCM_EXPANDED_TYPE_CODE)
+
+
+
+
+
+#define SCM_EXPANDED_VOID_TYPE_NAME "void"
+#define SCM_EXPANDED_VOID_FIELD_NAMES \
+ { "src" }
+enum
+ {
+ SCM_EXPANDED_VOID_SRC,
+ SCM_NUM_EXPANDED_VOID_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_VOID(src) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_VOID], 0, SCM_NUM_EXPANDED_VOID_FIELDS, SCM_UNPACK (src))
+
+#define SCM_EXPANDED_CONST_TYPE_NAME "const"
+#define SCM_EXPANDED_CONST_FIELD_NAMES \
+ { "src", "exp", }
+enum
+ {
+ SCM_EXPANDED_CONST_SRC,
+ SCM_EXPANDED_CONST_EXP,
+ SCM_NUM_EXPANDED_CONST_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_CONST(src, exp) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_CONST], 0, SCM_NUM_EXPANDED_CONST_FIELDS, SCM_UNPACK (src), SCM_UNPACK (exp))
+
+#define SCM_EXPANDED_PRIMITIVE_REF_TYPE_NAME "primitive-ref"
+#define SCM_EXPANDED_PRIMITIVE_REF_FIELD_NAMES \
+ { "src", "name", }
+enum
+ {
+ SCM_EXPANDED_PRIMITIVE_REF_SRC,
+ SCM_EXPANDED_PRIMITIVE_REF_NAME,
+ SCM_NUM_EXPANDED_PRIMITIVE_REF_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_PRIMITIVE_REF], 0, SCM_NUM_EXPANDED_PRIMITIVE_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name))
+
+#define SCM_EXPANDED_LEXICAL_REF_TYPE_NAME "lexical-ref"
+#define SCM_EXPANDED_LEXICAL_REF_FIELD_NAMES \
+ { "src", "name", "gensym", }
+enum
+ {
+ SCM_EXPANDED_LEXICAL_REF_SRC,
+ SCM_EXPANDED_LEXICAL_REF_NAME,
+ SCM_EXPANDED_LEXICAL_REF_GENSYM,
+ SCM_NUM_EXPANDED_LEXICAL_REF_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_LEXICAL_REF], 0, SCM_NUM_EXPANDED_LEXICAL_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (gensym))
+
+#define SCM_EXPANDED_LEXICAL_SET_TYPE_NAME "lexical-set"
+#define SCM_EXPANDED_LEXICAL_SET_FIELD_NAMES \
+ { "src", "name", "gensym", "exp", }
+enum
+ {
+ SCM_EXPANDED_LEXICAL_SET_SRC,
+ SCM_EXPANDED_LEXICAL_SET_NAME,
+ SCM_EXPANDED_LEXICAL_SET_GENSYM,
+ SCM_EXPANDED_LEXICAL_SET_EXP,
+ SCM_NUM_EXPANDED_LEXICAL_SET_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_LEXICAL_SET], 0, SCM_NUM_EXPANDED_LEXICAL_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (gensym), SCM_UNPACK (exp))
+
+#define SCM_EXPANDED_MODULE_REF_TYPE_NAME "module-ref"
+#define SCM_EXPANDED_MODULE_REF_FIELD_NAMES \
+ { "src", "mod", "name", "public", }
+enum
+ {
+ SCM_EXPANDED_MODULE_REF_SRC,
+ SCM_EXPANDED_MODULE_REF_MOD,
+ SCM_EXPANDED_MODULE_REF_NAME,
+ SCM_EXPANDED_MODULE_REF_PUBLIC,
+ SCM_NUM_EXPANDED_MODULE_REF_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_MODULE_REF], 0, SCM_NUM_EXPANDED_MODULE_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod), SCM_UNPACK (name), SCM_UNPACK (public))
+
+#define SCM_EXPANDED_MODULE_SET_TYPE_NAME "module-set"
+#define SCM_EXPANDED_MODULE_SET_FIELD_NAMES \
+ { "src", "mod", "name", "public", "exp", }
+enum
+ {
+ SCM_EXPANDED_MODULE_SET_SRC,
+ SCM_EXPANDED_MODULE_SET_MOD,
+ SCM_EXPANDED_MODULE_SET_NAME,
+ SCM_EXPANDED_MODULE_SET_PUBLIC,
+ SCM_EXPANDED_MODULE_SET_EXP,
+ SCM_NUM_EXPANDED_MODULE_SET_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_MODULE_SET], 0, SCM_NUM_EXPANDED_MODULE_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (mod), SCM_UNPACK (name), SCM_UNPACK (public), SCM_UNPACK (exp))
+
+#define SCM_EXPANDED_TOPLEVEL_REF_TYPE_NAME "toplevel-ref"
+#define SCM_EXPANDED_TOPLEVEL_REF_FIELD_NAMES \
+ { "src", "name", }
+enum
+ {
+ SCM_EXPANDED_TOPLEVEL_REF_SRC,
+ SCM_EXPANDED_TOPLEVEL_REF_NAME,
+ SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, name) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_REF], 0, SCM_NUM_EXPANDED_TOPLEVEL_REF_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name))
+
+#define SCM_EXPANDED_TOPLEVEL_SET_TYPE_NAME "toplevel-set"
+#define SCM_EXPANDED_TOPLEVEL_SET_FIELD_NAMES \
+ { "src", "name", "exp", }
+enum
+ {
+ SCM_EXPANDED_TOPLEVEL_SET_SRC,
+ SCM_EXPANDED_TOPLEVEL_SET_NAME,
+ SCM_EXPANDED_TOPLEVEL_SET_EXP,
+ SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, name, exp) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_SET], 0, SCM_NUM_EXPANDED_TOPLEVEL_SET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (exp))
+
+#define SCM_EXPANDED_TOPLEVEL_DEFINE_TYPE_NAME "toplevel-define"
+#define SCM_EXPANDED_TOPLEVEL_DEFINE_FIELD_NAMES \
+ { "src", "name", "exp", }
+enum
+ {
+ SCM_EXPANDED_TOPLEVEL_DEFINE_SRC,
+ SCM_EXPANDED_TOPLEVEL_DEFINE_NAME,
+ SCM_EXPANDED_TOPLEVEL_DEFINE_EXP,
+ SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, name, exp) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_TOPLEVEL_DEFINE], 0, SCM_NUM_EXPANDED_TOPLEVEL_DEFINE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (name), SCM_UNPACK (exp))
+
+#define SCM_EXPANDED_CONDITIONAL_TYPE_NAME "conditional"
+#define SCM_EXPANDED_CONDITIONAL_FIELD_NAMES \
+ { "src", "test", "consequent", "alternate", }
+enum
+ {
+ SCM_EXPANDED_CONDITIONAL_SRC,
+ SCM_EXPANDED_CONDITIONAL_TEST,
+ SCM_EXPANDED_CONDITIONAL_CONSEQUENT,
+ SCM_EXPANDED_CONDITIONAL_ALTERNATE,
+ SCM_NUM_EXPANDED_CONDITIONAL_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_CONDITIONAL], 0, SCM_NUM_EXPANDED_CONDITIONAL_FIELDS, SCM_UNPACK (src), SCM_UNPACK (test), SCM_UNPACK (consequent), SCM_UNPACK (alternate))
+
+#define SCM_EXPANDED_APPLICATION_TYPE_NAME "application"
+#define SCM_EXPANDED_APPLICATION_FIELD_NAMES \
+ { "src", "proc", "exps", }
+enum
+ {
+ SCM_EXPANDED_APPLICATION_SRC,
+ SCM_EXPANDED_APPLICATION_PROC,
+ SCM_EXPANDED_APPLICATION_EXPS,
+ SCM_NUM_EXPANDED_APPLICATION_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_APPLICATION(src, proc, exps) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_APPLICATION], 0, SCM_NUM_EXPANDED_APPLICATION_FIELDS, SCM_UNPACK (src), SCM_UNPACK (proc), SCM_UNPACK (exps))
+
+#define SCM_EXPANDED_SEQUENCE_TYPE_NAME "sequence"
+#define SCM_EXPANDED_SEQUENCE_FIELD_NAMES \
+ { "src", "exps", }
+enum
+ {
+ SCM_EXPANDED_SEQUENCE_SRC,
+ SCM_EXPANDED_SEQUENCE_EXPS,
+ SCM_NUM_EXPANDED_SEQUENCE_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_SEQUENCE(src, exps) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_SEQUENCE], 0, SCM_NUM_EXPANDED_SEQUENCE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (exps))
+
+#define SCM_EXPANDED_LAMBDA_TYPE_NAME "lambda"
+#define SCM_EXPANDED_LAMBDA_FIELD_NAMES \
+ { "src", "meta", "body", }
+enum
+ {
+ SCM_EXPANDED_LAMBDA_SRC,
+ SCM_EXPANDED_LAMBDA_META,
+ SCM_EXPANDED_LAMBDA_BODY,
+ SCM_NUM_EXPANDED_LAMBDA_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_LAMBDA(src, meta, body) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_LAMBDA], 0, SCM_NUM_EXPANDED_LAMBDA_FIELDS, SCM_UNPACK (src), SCM_UNPACK (meta), SCM_UNPACK (body))
+
+#define SCM_EXPANDED_LAMBDA_CASE_TYPE_NAME "lambda-case"
+#define SCM_EXPANDED_LAMBDA_CASE_FIELD_NAMES \
+ { "src", "req", "opt", "rest", "kw", "inits", "gensyms", "body", "alternate", }
+enum
+ {
+ SCM_EXPANDED_LAMBDA_CASE_SRC,
+ SCM_EXPANDED_LAMBDA_CASE_REQ,
+ SCM_EXPANDED_LAMBDA_CASE_OPT,
+ SCM_EXPANDED_LAMBDA_CASE_REST,
+ SCM_EXPANDED_LAMBDA_CASE_KW,
+ SCM_EXPANDED_LAMBDA_CASE_INITS,
+ SCM_EXPANDED_LAMBDA_CASE_GENSYMS,
+ SCM_EXPANDED_LAMBDA_CASE_BODY,
+ SCM_EXPANDED_LAMBDA_CASE_ALTERNATE,
+ SCM_NUM_EXPANDED_LAMBDA_CASE_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_LAMBDA_CASE], 0, SCM_NUM_EXPANDED_LAMBDA_CASE_FIELDS, SCM_UNPACK (src), SCM_UNPACK (req), SCM_UNPACK (opt), SCM_UNPACK (rest), SCM_UNPACK (kw), SCM_UNPACK (inits), SCM_UNPACK (gensyms), SCM_UNPACK (body), SCM_UNPACK (alternate))
+
+#define SCM_EXPANDED_LET_TYPE_NAME "let"
+#define SCM_EXPANDED_LET_FIELD_NAMES \
+ { "src", "names", "gensyms", "vals", "body", }
+enum
+ {
+ SCM_EXPANDED_LET_SRC,
+ SCM_EXPANDED_LET_NAMES,
+ SCM_EXPANDED_LET_GENSYMS,
+ SCM_EXPANDED_LET_VALS,
+ SCM_EXPANDED_LET_BODY,
+ SCM_NUM_EXPANDED_LET_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_LET], 0, SCM_NUM_EXPANDED_LET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (names), SCM_UNPACK (gensyms), SCM_UNPACK (vals), SCM_UNPACK (body))
+
+#define SCM_EXPANDED_LETREC_TYPE_NAME "letrec"
+#define SCM_EXPANDED_LETREC_FIELD_NAMES \
+ { "src", "names", "gensyms", "vals", "body", }
+enum
+ {
+ SCM_EXPANDED_LETREC_SRC,
+ SCM_EXPANDED_LETREC_NAMES,
+ SCM_EXPANDED_LETREC_GENSYMS,
+ SCM_EXPANDED_LETREC_VALS,
+ SCM_EXPANDED_LETREC_BODY,
+ SCM_NUM_EXPANDED_LETREC_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_LETREC(src, names, gensyms, vals, body) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_LETREC], 0, SCM_NUM_EXPANDED_LETREC_FIELDS, SCM_UNPACK (src), SCM_UNPACK (names), SCM_UNPACK (gensyms), SCM_UNPACK (vals), SCM_UNPACK (body))
+
+#define SCM_EXPANDED_DYNLET_TYPE_NAME "dynlet"
+#define SCM_EXPANDED_DYNLET_FIELD_NAMES \
+ { "src", "fluids", "vals", "body", }
+enum
+ {
+ SCM_EXPANDED_DYNLET_SRC,
+ SCM_EXPANDED_DYNLET_FLUIDS,
+ SCM_EXPANDED_DYNLET_VALS,
+ SCM_EXPANDED_DYNLET_BODY,
+ SCM_NUM_EXPANDED_DYNLET_FIELDS,
+ };
+#define SCM_MAKE_EXPANDED_DYNLET(src, fluids, vals, body) \
+ scm_c_make_struct (exp_vtables[SCM_EXPANDED_DYNLET], 0, SCM_NUM_EXPANDED_DYNLET_FIELDS, SCM_UNPACK (src), SCM_UNPACK (fluids), SCM_UNPACK (vals), SCM_UNPACK (body))
+
+#endif /* BUILDING_LIBGUILE */
+
+
+
+SCM_INTERNAL SCM scm_macroexpand (SCM exp);
+
+SCM_INTERNAL void scm_init_expand (void);
+
+
+#endif /* SCM_EXPAND_H */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
diff --git a/libguile/init.c b/libguile/init.c
index 0d4f8c227..6313b6544 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -54,6 +54,7 @@
#include "libguile/error.h"
#include "libguile/eval.h"
#include "libguile/evalext.h"
+#include "libguile/expand.h"
#include "libguile/feature.h"
#include "libguile/filesys.h"
#include "libguile/fluids.h"
@@ -546,6 +547,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_guardians (); /* requires smob_prehistory */
scm_init_vports ();
scm_init_standard_ports (); /* Requires fports */
+ scm_init_expand (); /* Requires structs */
scm_init_memoize (); /* Requires smob_prehistory */
scm_init_eval (); /* Requires smob_prehistory */
scm_init_load_path ();
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 8cd80f1d3..d23a390af 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -27,6 +27,7 @@
#include "libguile/_scm.h"
#include "libguile/continuations.h"
#include "libguile/eq.h"
+#include "libguile/expand.h"
#include "libguile/list.h"
#include "libguile/macros.h"
#include "libguile/memoize.h"
@@ -53,117 +54,7 @@
#define CADDDR(x) SCM_CADDDR(x)
-static const char s_bad_expression[] = "Bad expression";
-static const char s_expression[] = "Missing or extra expression in";
-static const char s_missing_expression[] = "Missing expression in";
-static const char s_extra_expression[] = "Extra expression in";
-static const char s_empty_combination[] = "Illegal empty combination";
-static const char s_missing_body_expression[] = "Missing body expression in";
-static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
-static const char s_bad_define[] = "Bad define placement";
-static const char s_missing_clauses[] = "Missing clauses";
-static const char s_misplaced_else_clause[] = "Misplaced else clause";
-static const char s_bad_case_clause[] = "Bad case clause";
-static const char s_bad_case_labels[] = "Bad case labels";
-static const char s_duplicate_case_label[] = "Duplicate case label";
-static const char s_bad_cond_clause[] = "Bad cond clause";
-static const char s_missing_recipient[] = "Missing recipient in";
-static const char s_bad_variable[] = "Bad variable";
-static const char s_bad_bindings[] = "Bad bindings";
-static const char s_bad_binding[] = "Bad binding";
-static const char s_duplicate_binding[] = "Duplicate binding";
-static const char s_bad_exit_clause[] = "Bad exit clause";
-static const char s_bad_formals[] = "Bad formals";
-static const char s_bad_formal[] = "Bad formal";
-static const char s_duplicate_formal[] = "Duplicate formal";
-static const char s_splicing[] = "Non-list result for unquote-splicing";
-static const char s_bad_slot_number[] = "Bad slot number";
-
-
-/* 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>. */
-
-SCM_SYMBOL (syntax_error_key, "syntax-error");
-
-/* The prototype is needed to indicate that the function does not return. */
-static void
-syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
-
-static void
-syntax_error (const char* const msg, const SCM form, const SCM expr)
-{
- SCM msg_string = scm_from_locale_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);
- }
- }
- 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);
- }
- }
-
- scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
-}
-
-
-/* Shortcut macros to simplify syntax error handling. */
-#define ASSERT_SYNTAX(cond, message, form) \
- { if (SCM_UNLIKELY (!(cond))) \
- syntax_error (message, form, SCM_UNDEFINED); }
-#define ASSERT_SYNTAX_2(cond, message, form, expr) \
- { if (SCM_UNLIKELY (!(cond))) \
- syntax_error (message, form, expr); }
+SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
@@ -262,993 +153,246 @@ scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
return 1;
}
-static SCM scm_m_at (SCM xorig, SCM env);
-static SCM scm_m_atat (SCM xorig, SCM env);
-static SCM scm_m_and (SCM xorig, SCM env);
-static SCM scm_m_begin (SCM xorig, SCM env);
-static SCM scm_m_cond (SCM xorig, SCM env);
-static SCM scm_m_define (SCM x, SCM env);
-static SCM scm_m_with_fluids (SCM xorig, SCM env);
-static SCM scm_m_eval_when (SCM xorig, SCM env);
-static SCM scm_m_if (SCM xorig, SCM env);
-static SCM scm_m_lambda (SCM xorig, SCM env);
-static SCM scm_m_lambda_star (SCM xorig, SCM env);
-static SCM scm_m_case_lambda (SCM xorig, SCM env);
-static SCM scm_m_case_lambda_star (SCM xorig, SCM env);
-static SCM scm_m_let (SCM xorig, SCM env);
-static SCM scm_m_letrec (SCM xorig, SCM env);
-static SCM scm_m_letstar (SCM xorig, SCM env);
-static SCM scm_m_or (SCM xorig, SCM env);
-static SCM scm_m_quote (SCM xorig, SCM env);
-static SCM scm_m_set_x (SCM xorig, SCM env);
-static SCM
-memoize_env_ref_macro (SCM env, SCM x)
-{
- SCM var;
- for (; scm_is_pair (env); env = CDR (env))
- if (scm_is_eq (x, CAR (env)))
- return SCM_BOOL_F; /* lexical */
-
- var = scm_module_variable (env, x);
- if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
- && (scm_is_true (scm_macro_p (scm_variable_ref (var)))
- || SCM_MEMOIZER_P (scm_variable_ref (var))))
- return scm_variable_ref (var);
- else
- return SCM_BOOL_F; /* anything else */
-}
-
static int
-memoize_env_var_is_free (SCM env, SCM x)
-{
- for (; scm_is_pair (env); env = CDR (env))
- if (scm_is_eq (x, CAR (env)))
- return 0; /* bound */
- return 1; /* free */
-}
-
-static int
-memoize_env_lexical_index (SCM env, SCM x)
+lookup (SCM x, SCM env)
{
int i = 0;
for (; scm_is_pair (env); env = CDR (env), i++)
if (scm_is_eq (x, CAR (env)))
return i; /* bound */
- return -1; /* free */
-}
-
-static SCM
-memoize_env_extend (SCM env, SCM vars)
-{
- return scm_append (scm_list_2 (vars, env));
+ abort ();
}
-static SCM
-memoize (SCM exp, SCM env)
-{
- if (scm_is_pair (exp))
- {
- SCM car;
- scm_t_macro_primitive trans = NULL;
- SCM macro = SCM_BOOL_F, memoizer = SCM_BOOL_F;
-
- car = CAR (exp);
- if (scm_is_symbol (car))
- macro = memoize_env_ref_macro (env, car);
-
- if (scm_is_true (scm_macro_p (macro)))
- trans = scm_i_macro_primitive (macro);
- else if (SCM_MEMOIZER_P (macro))
- memoizer = SCM_MEMOIZER (macro);
-
- if (trans)
- return trans (exp, env);
- else
- {
- SCM args = SCM_EOL;
- int nargs = 0;
- SCM proc = CAR (exp);
-
- for (exp = CDR (exp); scm_is_pair (exp); exp = CDR (exp), nargs++)
- args = scm_cons (memoize (CAR (exp), env), args);
- if (scm_is_null (exp))
- {
- if (scm_is_true (memoizer))
- return scm_apply (memoizer, scm_reverse_x (args, SCM_UNDEFINED),
- SCM_EOL);
- else
- return MAKMEMO_CALL (memoize (proc, env),
- nargs,
- scm_reverse_x (args, SCM_UNDEFINED));
- }
-
- else
- syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
- }
- }
- else if (scm_is_symbol (exp))
- {
- int i = memoize_env_lexical_index (env, exp);
- if (i < 0)
- return MAKMEMO_TOP_REF (exp);
- else
- return MAKMEMO_LEX_REF (i);
- }
- else
- return MAKMEMO_QUOTE (exp);
-}
-
-static SCM
-memoize_exprs (SCM forms, const SCM env)
-{
- SCM ret = SCM_EOL;
-
- for (; !scm_is_null (forms); forms = CDR (forms))
- ret = scm_cons (memoize (CAR (forms), env), ret);
- return scm_reverse_x (ret, SCM_UNDEFINED);
-}
-static SCM
-memoize_sequence (const SCM forms, const SCM env)
-{
- ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
- scm_cons (scm_sym_begin, forms));
- if (scm_is_null (CDR (forms)))
- return memoize (CAR (forms), env);
- else
- return MAKMEMO_BEGIN (memoize_exprs (forms, env));
-}
+/* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
+#define REF(x,type,field) \
+ (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
+static SCM list_of_guile = SCM_BOOL_F;
-
-/* Memoization. */
-
-#define SCM_SYNTAX(RANAME, STR, CFN) \
-SCM_SNARF_HERE(static const char RANAME[]=STR)\
-SCM_SNARF_INIT(scm_c_define (RANAME, scm_i_make_primitive_macro (RANAME, CFN)))
-
-
-/* True primitive syntax */
-SCM_SYNTAX (s_at, "@", scm_m_at);
-SCM_SYNTAX (s_atat, "@@", scm_m_atat);
-SCM_SYNTAX (s_begin, "begin", scm_m_begin);
-SCM_SYNTAX (s_define, "define", scm_m_define);
-SCM_SYNTAX (s_with_fluids, "with-fluids", scm_m_with_fluids);
-SCM_SYNTAX (s_eval_when, "eval-when", scm_m_eval_when);
-SCM_SYNTAX (s_if, "if", scm_m_if);
-SCM_SYNTAX (s_lambda, "lambda", scm_m_lambda);
-SCM_SYNTAX (s_let, "let", scm_m_let);
-SCM_SYNTAX (s_quote, "quote", scm_m_quote);
-SCM_SYNTAX (s_set_x, "set!", scm_m_set_x);
-
-/* Convenient syntax during boot, expands to primitive syntax. Replaced after
- psyntax boots. */
-SCM_SYNTAX (s_and, "and", scm_m_and);
-SCM_SYNTAX (s_cond, "cond", scm_m_cond);
-SCM_SYNTAX (s_letrec, "letrec", scm_m_letrec);
-SCM_SYNTAX (s_letstar, "let*", scm_m_letstar);
-SCM_SYNTAX (s_or, "or", scm_m_or);
-SCM_SYNTAX (s_lambda_star, "lambda*", scm_m_lambda_star);
-SCM_SYNTAX (s_case_lambda, "case-lambda", scm_m_case_lambda);
-SCM_SYNTAX (s_case_lambda_star, "case-lambda*", scm_m_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_lambda, "lambda");
-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_GLOBAL_SYMBOL (scm_sym_quote, "quote");
-SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
-SCM_SYMBOL (sym_lambda_star, "lambda*");
-SCM_SYMBOL (sym_case_lambda, "case-lambda");
-SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
-SCM_SYMBOL (sym_eval, "eval");
-SCM_SYMBOL (sym_load, "load");
-
-SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
-SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
-SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
-
-SCM_KEYWORD (kw_allow_other_keys, "allow-other-keys");
-SCM_KEYWORD (kw_optional, "optional");
-SCM_KEYWORD (kw_key, "key");
-SCM_KEYWORD (kw_rest, "rest");
-
+static SCM memoize (SCM exp, SCM env);
static SCM
-scm_m_at (SCM expr, SCM env SCM_UNUSED)
+memoize_exps (SCM exps, SCM env)
{
- 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);
-
- return MAKMEMO_MOD_REF (CADR (expr), CADDR (expr), SCM_BOOL_T);
-}
-
-static SCM
-scm_m_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);
-
- return MAKMEMO_MOD_REF (CADR (expr), CADDR (expr), SCM_BOOL_F);
-}
-
-static SCM
-scm_m_and (SCM expr, SCM env)
-{
- const SCM cdr_expr = CDR (expr);
-
- if (scm_is_null (cdr_expr))
- return MAKMEMO_QUOTE (SCM_BOOL_T);
- ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
-
- if (scm_is_null (CDR (cdr_expr)))
- return memoize (CAR (cdr_expr), env);
- else
- return MAKMEMO_IF (memoize (CAR (cdr_expr), env),
- scm_m_and (cdr_expr, env),
- MAKMEMO_QUOTE (SCM_BOOL_F));
-}
-
-static SCM
-scm_m_begin (SCM expr, SCM env)
-{
- const SCM cdr_expr = CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr);
- return MAKMEMO_BEGIN (memoize_exprs (cdr_expr, env));
-}
-
-static SCM
-scm_m_cond (SCM expr, SCM env)
-{
- /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
- const int else_literal_p = memoize_env_var_is_free (env, scm_sym_else);
- const int arrow_literal_p = memoize_env_var_is_free (env, scm_sym_arrow);
-
- const SCM clauses = CDR (expr);
- SCM clause_idx;
- SCM ret, loc;
-
- ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
-
- ret = scm_cons (SCM_UNDEFINED, MAKMEMO_QUOTE (SCM_UNSPECIFIED));
- loc = ret;
-
- for (clause_idx = clauses;
- !scm_is_null (clause_idx);
- clause_idx = CDR (clause_idx))
- {
- SCM test;
-
- const SCM clause = CAR (clause_idx);
- const long length = scm_ilength (clause);
- ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr);
-
- test = CAR (clause);
- if (scm_is_eq (test, scm_sym_else) && else_literal_p)
- {
- const int last_clause_p = scm_is_null (CDR (clause_idx));
- ASSERT_SYNTAX_2 (length >= 2,
- s_bad_cond_clause, clause, expr);
- ASSERT_SYNTAX_2 (last_clause_p,
- s_misplaced_else_clause, clause, expr);
- SCM_SETCDR (loc,
- memoize (scm_cons (scm_sym_begin, CDR (clause)), env));
- }
- else if (length >= 2
- && scm_is_eq (CADR (clause), scm_sym_arrow)
- && arrow_literal_p)
- {
- SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
- SCM i;
- SCM new_env = scm_cons (tmp, env);
- ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
- ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
- i = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
- MAKMEMO_CALL (memoize (CADDR (clause),
- scm_cons (tmp, new_env)),
- 1,
- scm_list_1 (MAKMEMO_LEX_REF (0))),
- MAKMEMO_QUOTE (SCM_UNSPECIFIED));
- SCM_SETCDR (loc,
- MAKMEMO_LET (scm_list_1 (memoize (CAR (clause), env)),
- i));
- env = new_env;
- loc = scm_last_pair (SCM_MEMOIZED_ARGS (i));
- }
- /* FIXME length == 1 case */
- else
- {
- SCM i = MAKMEMO_IF (memoize (CAR (clause), env),
- memoize (scm_cons (scm_sym_begin, CDR (clause)), env),
- MAKMEMO_QUOTE (SCM_UNSPECIFIED));
- SCM_SETCDR (loc, i);
- loc = scm_last_pair (SCM_MEMOIZED_ARGS (i));
- }
- }
-
- return CDR (ret);
-}
-
-/* According to Section 5.2.1 of R5RS we first have to make sure that the
- variable is bound, and then perform the `(set! variable expression)'
- operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
- bound. This means that EXPRESSION won't necessarily be able to assign
- values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
-static SCM
-scm_m_define (SCM expr, SCM env)
-{
- const SCM cdr_expr = CDR (expr);
- SCM body;
- SCM variable;
-
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
- ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);
-
- body = CDR (cdr_expr);
- variable = CAR (cdr_expr);
-
- if (scm_is_pair (variable))
- {
- ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
- return MAKMEMO_DEFINE (CAR (variable),
- memoize (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 MAKMEMO_DEFINE (variable, memoize (CAR (body), env));
-}
-
-static SCM
-scm_m_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 (memoize (CAR (binding), env), fluids);
- vals = scm_cons (memoize (CADR (binding), env), vals);
- }
-
- return MAKMEMO_WITH_FLUIDS (scm_reverse_x (fluids, SCM_UNDEFINED),
- scm_reverse_x (vals, SCM_UNDEFINED),
- memoize_sequence (CDDR (expr), env));
-}
-
-static SCM
-scm_m_eval_when (SCM expr, SCM env)
-{
- ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
-
- if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
- || scm_is_true (scm_memq (sym_load, CADR (expr))))
- return MAKMEMO_BEGIN (memoize_exprs (CDDR (expr), env));
- else
- return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
-}
-
-static SCM
-scm_m_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 MAKMEMO_IF (memoize (CADR (expr), env),
- memoize (CADDR (expr), env),
- ((length == 3)
- ? memoize (CADDDR (expr), env)
- : MAKMEMO_QUOTE (SCM_UNSPECIFIED)));
-}
-
-/* A helper function for memoize_lambda to support checking for duplicate
- * formal arguments: Return true if OBJ is `eq?' to one of the elements of
- * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
- * forms that a formal argument can have:
- * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
-static int
-c_improper_memq (SCM obj, SCM list)
-{
- for (; scm_is_pair (list); list = CDR (list))
- {
- if (scm_is_eq (CAR (list), obj))
- return 1;
- }
- return scm_is_eq (list, obj);
-}
-
-static SCM
-scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
-{
- SCM formals;
- SCM formals_idx;
- SCM formal_vars = SCM_EOL;
- SCM body;
- int nreq = 0;
-
- 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);
-
- /* Before iterating the list of formal arguments, make sure the formals
- * actually are given as either a symbol or a non-cyclic list. */
- formals = CAR (cdr_expr);
- if (scm_is_pair (formals))
- {
- /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
- * detected, report a 'Bad formals' error. */
- }
- else
- {
- ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
- s_bad_formals, formals, expr);
- }
-
- /* Now iterate the list of formal arguments to check if all formals are
- * symbols, and that there are no duplicates. */
- formals_idx = formals;
- while (scm_is_pair (formals_idx))
- {
- const SCM formal = CAR (formals_idx);
- const SCM next_idx = CDR (formals_idx);
- ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal, expr);
- ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx),
- s_duplicate_formal, formal, expr);
- nreq++;
- formal_vars = scm_cons (formal, formal_vars);
- formals_idx = next_idx;
- }
- ASSERT_SYNTAX_2 (scm_is_null (formals_idx) || scm_is_symbol (formals_idx),
- s_bad_formal, formals_idx, expr);
- if (scm_is_symbol (formals_idx))
- formal_vars = scm_cons (formals_idx, formal_vars);
-
- body = memoize_sequence (CDDR (expr), memoize_env_extend (env, formal_vars));
-
- if (scm_is_symbol (formals_idx))
- return MAKMEMO_LAMBDA (body, REST_ARITY (nreq, SCM_BOOL_T));
- else
- return MAKMEMO_LAMBDA (body, FIXED_ARITY (nreq));
-}
-
-static SCM
-scm_m_lambda_star (SCM expr, SCM env)
-{
- SCM req, opt, kw, allow_other_keys, rest, formals, body;
- SCM inits, kw_indices;
- int nreq, nopt;
-
- const long length = scm_ilength (expr);
- ASSERT_SYNTAX (length >= 1, s_bad_expression, expr);
- ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
-
- formals = CADR (expr);
- body = CDDR (expr);
-
- nreq = nopt = 0;
- req = opt = kw = SCM_EOL;
- rest = allow_other_keys = SCM_BOOL_F;
-
- while (scm_is_pair (formals) && scm_is_symbol (CAR (formals)))
- {
- nreq++;
- req = scm_cons (CAR (formals), req);
- formals = scm_cdr (formals);
- }
-
- if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_optional))
- {
- formals = CDR (formals);
- while (scm_is_pair (formals)
- && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
- {
- nopt++;
- opt = scm_cons (CAR (formals), opt);
- formals = scm_cdr (formals);
- }
- }
-
- if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_key))
- {
- formals = CDR (formals);
- while (scm_is_pair (formals)
- && (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
- {
- kw = scm_cons (CAR (formals), kw);
- formals = scm_cdr (formals);
- }
- }
-
- if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_allow_other_keys))
- {
- formals = CDR (formals);
- allow_other_keys = SCM_BOOL_T;
- }
-
- if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_rest))
- {
- if (scm_ilength (formals) != 2)
- syntax_error (s_bad_formals, CADR (expr), expr);
- else
- rest = CADR (formals);
- }
- else if (scm_is_symbol (formals))
- rest = formals;
- else if (!scm_is_null (formals))
- syntax_error (s_bad_formals, CADR (expr), expr);
- else
- rest = SCM_BOOL_F;
-
- /* Now, iterate through them a second time, building up an expansion-time
- environment, checking, expanding and canonicalizing the opt/kw init forms,
- and eventually memoizing the body as well. Note that the rest argument, if
- any, is expanded before keyword args, thus necessitating the second
- pass.
-
- Also note that the specific environment during expansion of init
- expressions here needs to coincide with the environment when psyntax
- expands. A lot of effort for something that is only used in the bootstrap
- memoizer, you say? Yes. Yes it is.
- */
-
- inits = SCM_EOL;
-
- /* nreq is already set, and req is already reversed: simply extend. */
- env = memoize_env_extend (env, req);
-
- /* Build up opt inits and env */
- opt = scm_reverse_x (opt, SCM_EOL);
- while (scm_is_pair (opt))
- {
- SCM x = CAR (opt);
- if (scm_is_symbol (x))
- inits = scm_cons (MAKMEMO_QUOTE (SCM_BOOL_F), inits);
- else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
- inits = scm_cons (memoize (CADR (x), env), inits);
- else
- syntax_error (s_bad_formals, CADR (expr), expr);
- env = scm_cons (scm_is_symbol (x) ? x : CAR (x), env);
- opt = CDR (opt);
- }
-
- /* Process rest before keyword args */
- if (scm_is_true (rest))
- env = scm_cons (rest, env);
-
- /* Build up kw inits, env, and kw-indices alist */
- if (scm_is_null (kw))
- kw_indices = SCM_BOOL_F;
- else
- {
- int idx = nreq + nopt + (scm_is_true (rest) ? 1 : 0);
-
- kw_indices = SCM_EOL;
- kw = scm_reverse_x (kw, SCM_EOL);
- while (scm_is_pair (kw))
- {
- SCM x, sym, k, init;
- x = CAR (kw);
- if (scm_is_symbol (x))
- {
- sym = x;
- init = SCM_BOOL_F;
- k = scm_symbol_to_keyword (sym);
- }
- else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
- {
- sym = CAR (x);
- init = CADR (x);
- k = scm_symbol_to_keyword (sym);
- }
- else if (scm_ilength (x) == 3 && scm_is_symbol (CAR (x))
- && scm_is_keyword (CADDR (x)))
- {
- sym = CAR (x);
- init = CADR (x);
- k = CADDR (x);
- }
- else
- syntax_error (s_bad_formals, CADR (expr), expr);
-
- kw_indices = scm_acons (k, SCM_I_MAKINUM (idx++), kw_indices);
- inits = scm_cons (memoize (init, env), inits);
- env = scm_cons (sym, env);
- kw = CDR (kw);
- }
- kw_indices = scm_cons (allow_other_keys,
- scm_reverse_x (kw_indices, SCM_UNDEFINED));
- }
-
- /* We should check for no duplicates, but given that psyntax does this
- already, we can punt on it here... */
-
- inits = scm_reverse_x (inits, SCM_UNDEFINED);
- body = memoize_sequence (body, env);
-
- if (scm_is_false (kw_indices) && scm_is_false (rest) && !nopt)
- return MAKMEMO_LAMBDA (body, FIXED_ARITY (nreq));
- if (scm_is_false (kw_indices) && !nopt)
- return MAKMEMO_LAMBDA (body, REST_ARITY (nreq, SCM_BOOL_T));
- else
- return MAKMEMO_LAMBDA (body, FULL_ARITY (nreq, rest, nopt, kw_indices, inits,
- SCM_BOOL_F));
-}
-
-static SCM
-patch_case_lambda (SCM a, SCM b)
-{
- SCM mx, body, rest, kw_indices, inits;
- int nreq, nopt;
-
- mx = SCM_SMOB_OBJECT_1 (a);
- body = CAR (mx);
- mx = CDR (mx);
-
- if (scm_is_null (CDR (mx)))
- {
- nreq = scm_to_int16 (CAR (mx));
- rest = SCM_BOOL_F;
- nopt = 0;
- kw_indices = SCM_BOOL_F;
- inits = SCM_EOL;
- }
- else if (scm_is_null (CDDR (mx)))
- {
- nreq = scm_to_int16 (CAR (mx));
- rest = CADR (mx);
- nopt = 0;
- kw_indices = SCM_BOOL_F;
- inits = SCM_EOL;
- }
- else
- {
- nreq = scm_to_int16 (CAR (mx));
- rest = CADR (mx);
- nopt = scm_to_int16 (CADDR (mx));
- kw_indices = CADDDR (mx);
- inits = CADR (CDDDR (mx));
- }
-
- return MAKMEMO_LAMBDA
- (body, FULL_ARITY (nreq, rest, nopt, kw_indices, inits, b));
+ SCM ret;
+ for (ret = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
+ ret = scm_cons (memoize (CAR (exps), env), ret);
+ return scm_reverse_x (ret, SCM_UNDEFINED);
}
-
-static SCM
-scm_m_case_lambda (SCM expr, SCM env)
-{
- SCM ret, clauses;
-
- const long length = scm_ilength (expr);
- ASSERT_SYNTAX (length >= 1, s_bad_expression, expr);
- ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
-
- clauses = scm_reverse (CDR (expr));
- ret = SCM_BOOL_F;
- for (; scm_is_pair (clauses); clauses = CDR (clauses))
- ret = patch_case_lambda
- (scm_m_lambda (scm_cons (scm_sym_lambda, CAR (clauses)), env), ret);
-
- return ret;
-}
-
static SCM
-scm_m_case_lambda_star (SCM expr, SCM env)
-{
- SCM ret, clauses;
-
- const long length = scm_ilength (expr);
- ASSERT_SYNTAX (length >= 1, s_bad_expression, expr);
- ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
-
- clauses = scm_reverse (CDR (expr));
- ret = SCM_BOOL_F;
-
- for (; scm_is_pair (clauses); clauses = CDR (clauses))
- ret = patch_case_lambda
- (scm_m_lambda_star (scm_cons (sym_lambda_star, CAR (clauses)), env), ret);
-
- return ret;
-}
-
-/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
-static void
-check_bindings (const SCM bindings, const SCM expr)
+memoize (SCM exp, SCM env)
{
- SCM binding_idx;
-
- ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
- s_bad_bindings, bindings, expr);
+ if (!SCM_EXPANDED_P (exp))
+ abort ();
- binding_idx = bindings;
- for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
+ switch (SCM_EXPANDED_TYPE (exp))
{
- SCM name; /* const */
-
- const SCM binding = CAR (binding_idx);
- ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
- s_bad_binding, binding, expr);
-
- name = CAR (binding);
- ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
- }
-}
+ case SCM_EXPANDED_VOID:
+ return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
+
+ case SCM_EXPANDED_CONST:
+ return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
-/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
- * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
- * variable name is detected, an error is signalled. */
-static int
-transform_bindings (const SCM bindings, const SCM expr,
- SCM *const rvarptr, SCM *const initptr)
-{
- SCM rvariables = SCM_EOL;
- SCM rinits = SCM_EOL;
- SCM binding_idx = bindings;
- int n = 0;
- for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
- {
- const SCM binding = CAR (binding_idx);
- const SCM CDR_binding = CDR (binding);
- const SCM name = CAR (binding);
- ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rvariables)),
- s_duplicate_binding, name, expr);
- rvariables = scm_cons (name, rvariables);
- rinits = scm_cons (CAR (CDR_binding), rinits);
- n++;
- }
- *rvarptr = rvariables;
- *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
- return n;
-}
+ case SCM_EXPANDED_PRIMITIVE_REF:
+ if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
+ return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
+ else
+ return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
+ SCM_BOOL_F);
+
+ case SCM_EXPANDED_LEXICAL_REF:
+ return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
+
+ case SCM_EXPANDED_LEXICAL_SET:
+ return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
+ memoize (REF (exp, LEXICAL_SET, EXP), env));
+
+ case SCM_EXPANDED_MODULE_REF:
+ return MAKMEMO_MOD_REF (REF (exp, MODULE_REF, MOD),
+ REF (exp, MODULE_REF, NAME),
+ REF (exp, MODULE_REF, PUBLIC));
+
+ case SCM_EXPANDED_MODULE_SET:
+ return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env),
+ REF (exp, MODULE_SET, MOD),
+ REF (exp, MODULE_SET, NAME),
+ REF (exp, MODULE_SET, PUBLIC));
+
+ case SCM_EXPANDED_TOPLEVEL_REF:
+ return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
+
+ case SCM_EXPANDED_TOPLEVEL_SET:
+ return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
+ memoize (REF (exp, TOPLEVEL_SET, EXP), env));
+
+ case SCM_EXPANDED_TOPLEVEL_DEFINE:
+ return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
+ memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env));
+
+ case SCM_EXPANDED_CONDITIONAL:
+ return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
+ memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
+ memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
+
+ case SCM_EXPANDED_APPLICATION:
+ {
+ SCM proc, args;
-/* This function is a helper function for memoize_let. It transforms
- * (let name ((var init) ...) body ...) into
- * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
- * and memoizes the expression. It is assumed that the caller has checked
- * that name is a symbol and that there are bindings and a body. */
-static SCM
-memoize_named_let (const SCM expr, SCM env)
-{
- SCM rvariables;
- SCM inits;
- int nreq;
-
- 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);
-
- nreq = transform_bindings (bindings, expr, &rvariables, &inits);
-
- env = scm_cons (name, env);
- return MAKMEMO_LET
- (scm_list_1 (MAKMEMO_QUOTE (SCM_UNDEFINED)),
- MAKMEMO_BEGIN
- (scm_list_2 (MAKMEMO_LEX_SET
- (0,
- MAKMEMO_LAMBDA (memoize_sequence
- (CDDDR (expr),
- memoize_env_extend (env, rvariables)),
- FIXED_ARITY (nreq))),
- MAKMEMO_CALL (MAKMEMO_LEX_REF (0),
- nreq,
- memoize_exprs (inits, env)))));
-}
+ proc = REF (exp, APPLICATION, PROC);
+ args = memoize_exps (REF (exp, APPLICATION, EXPS), env);
-/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
- * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
-static SCM
-scm_m_let (SCM expr, SCM env)
-{
- SCM bindings;
+ if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_TOPLEVEL_REF)
+ {
+ SCM var = scm_module_variable (scm_current_module (),
+ REF (proc, TOPLEVEL_REF, NAME));
+ if (SCM_VARIABLEP (var))
+ {
+ SCM val = SCM_VARIABLE_REF (var);
+ if (SCM_MEMOIZER_P (val))
+ return scm_apply (SCM_SMOB_OBJECT_1 (val), args, SCM_EOL);
+ }
+ }
+ /* otherwise we all fall down here */
+ return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
+ }
- 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);
+ case SCM_EXPANDED_SEQUENCE:
+ return MAKMEMO_BEGIN (memoize_exps (REF (exp, SEQUENCE, EXPS), env));
- bindings = CAR (cdr_expr);
- if (scm_is_symbol (bindings))
- {
- ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
- return memoize_named_let (expr, env);
- }
+ case SCM_EXPANDED_LAMBDA:
+ /* The body will be a lambda-case. */
+ return memoize (REF (exp, LAMBDA, BODY), env);
- check_bindings (bindings, expr);
- if (scm_is_null (bindings))
- return memoize_sequence (CDDR (expr), env);
- else
- {
- SCM rvariables;
- SCM inits;
- transform_bindings (bindings, expr, &rvariables, &inits);
- return MAKMEMO_LET (memoize_exprs (inits, env),
- memoize_sequence (CDDR (expr),
- memoize_env_extend (env, rvariables)));
- }
-}
+ case SCM_EXPANDED_LAMBDA_CASE:
+ {
+ SCM req, rest, opt, kw, inits, vars, body, alt;
+ SCM walk, minits, arity, new_env;
+ int nreq, nopt;
+
+ req = REF (exp, LAMBDA_CASE, REQ);
+ rest = REF (exp, LAMBDA_CASE, REST);
+ opt = REF (exp, LAMBDA_CASE, OPT);
+ kw = REF (exp, LAMBDA_CASE, KW);
+ inits = REF (exp, LAMBDA_CASE, INITS);
+ vars = REF (exp, LAMBDA_CASE, GENSYMS);
+ body = REF (exp, LAMBDA_CASE, BODY);
+ alt = REF (exp, LAMBDA_CASE, ALTERNATE);
+
+ nreq = scm_ilength (req);
+ nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
+
+ /* The vars are the gensyms, according to the divine plan. But we need
+ to memoize the inits within their appropriate environment,
+ complicating things. */
+ new_env = env;
+ for (walk = req; scm_is_pair (walk);
+ walk = CDR (walk), vars = CDR (vars))
+ new_env = scm_cons (CAR (vars), new_env);
+
+ minits = SCM_EOL;
+ for (walk = opt; scm_is_pair (walk);
+ walk = CDR (walk), vars = CDR (vars), inits = CDR (inits))
+ {
+ minits = scm_cons (memoize (CAR (inits), new_env), minits);
+ new_env = scm_cons (CAR (vars), new_env);
+ }
-static SCM
-scm_m_letrec (SCM expr, SCM env)
-{
- SCM bindings;
+ if (scm_is_true (rest))
+ {
+ new_env = scm_cons (CAR (vars), new_env);
+ vars = CDR (vars);
+ }
- const SCM cdr_expr = CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+ for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits))
+ {
+ minits = scm_cons (memoize (CAR (inits), new_env), minits);
+ new_env = scm_cons (CAR (vars), new_env);
+ }
+ if (!scm_is_null (vars))
+ abort ();
- bindings = CAR (cdr_expr);
- if (scm_is_null (bindings))
- return memoize_sequence (CDDR (expr), env);
- else
- {
- SCM rvariables;
- SCM inits;
- SCM v, i;
- SCM undefs = SCM_EOL;
- SCM vals = SCM_EOL;
- SCM sets = SCM_EOL;
- SCM new_env;
- int offset;
- int n = transform_bindings (bindings, expr, &rvariables, &inits);
- offset = n;
- new_env = memoize_env_extend (env, rvariables);
- for (v = scm_reverse (rvariables), i = inits; scm_is_pair (v);
- v = CDR (v), i = CDR (i), n--)
- {
- undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
- vals = scm_cons (memoize (CAR (i), new_env), vals);
- sets = scm_cons (MAKMEMO_LEX_SET ((n-1) + offset,
- MAKMEMO_LEX_REF (n-1)),
- sets);
- }
- return MAKMEMO_LET
- (undefs,
- MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (scm_reverse (vals),
- MAKMEMO_BEGIN (sets)),
- memoize_sequence (CDDR (expr),
- new_env))));
- }
-}
+ minits = scm_reverse_x (minits, SCM_UNDEFINED);
-static SCM
-scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
-{
- SCM bindings;
+ if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
+ {
+ if (scm_is_false (rest))
+ arity = FIXED_ARITY (nreq);
+ else
+ arity = REST_ARITY (nreq, SCM_BOOL_T);
+ }
+ else if (scm_is_true (alt))
+ arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
+ SCM_MEMOIZED_ARGS (memoize (alt, env)));
+ else
+ arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
- const SCM cdr_expr = CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+ return MAKMEMO_LAMBDA (memoize (body, new_env), arity);
+ }
- bindings = CAR (cdr_expr);
- if (scm_is_null (bindings))
- return memoize_sequence (CDDR (expr), env);
- else
- {
- SCM rvariables;
- SCM variables;
- SCM inits;
- SCM ret, loc;
- transform_bindings (bindings, expr, &rvariables, &inits);
- variables = scm_reverse (rvariables);
- ret = scm_cons (SCM_UNDEFINED, SCM_UNSPECIFIED);
- loc = ret;
- for (; scm_is_pair (variables);
- variables = CDR (variables), inits = CDR (inits))
- { SCM x = MAKMEMO_LET (scm_list_1 (memoize (CAR (inits), env)),
- MAKMEMO_QUOTE (SCM_UNSPECIFIED));
- SCM_SETCDR (loc, x);
- loc = scm_last_pair (SCM_MEMOIZED_ARGS (x));
- env = scm_cons (CAR (variables), env);
- }
- SCM_SETCDR (loc, memoize_sequence (CDDR (expr), env));
- return CDR (ret);
- }
-}
+ case SCM_EXPANDED_LET:
+ {
+ SCM vars, exps, body, inits, new_env;
+
+ vars = REF (exp, LET, GENSYMS);
+ exps = REF (exp, LET, VALS);
+ body = REF (exp, LET, BODY);
+
+ inits = SCM_EOL;
+ new_env = env;
+ for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps))
+ {
+ new_env = scm_cons (CAR (vars), new_env);
+ inits = scm_cons (memoize (CAR (exps), env), inits);
+ }
-static SCM
-scm_m_or (SCM expr, SCM env SCM_UNUSED)
-{
- SCM tail = CDR (expr);
- SCM ret, loc;
- const long length = scm_ilength (tail);
+ return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED),
+ memoize (body, new_env));
+ }
- ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ case SCM_EXPANDED_LETREC:
+ {
+ SCM vars, exps, body, undefs, inits, sets, new_env;
+ int i, nvars;
+
+ vars = REF (exp, LET, GENSYMS);
+ exps = REF (exp, LET, VALS);
+ body = REF (exp, LET, BODY);
+ nvars = i = scm_ilength (vars);
+ inits = undefs = sets = SCM_EOL;
+ new_env = env;
+
+ for (; scm_is_pair (vars); vars = CDR (vars), i--)
+ {
+ new_env = scm_cons (CAR (vars), new_env);
+ undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
+ sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
+ MAKMEMO_LEX_REF (i-1)),
+ sets);
+ }
- ret = scm_cons (SCM_UNDEFINED, SCM_UNSPECIFIED);
- loc = ret;
- for (; scm_is_pair (tail); tail = CDR (tail))
- {
- SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
- SCM x = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
- MAKMEMO_LEX_REF (0),
- MAKMEMO_QUOTE (SCM_UNSPECIFIED));
- SCM new_env = scm_cons (tmp, env);
- SCM_SETCDR (loc, MAKMEMO_LET (scm_list_1 (memoize (CAR (tail),
- env)),
- x));
- env = new_env;
- loc = scm_last_pair (SCM_MEMOIZED_ARGS (x));
- }
- SCM_SETCDR (loc, MAKMEMO_QUOTE (SCM_BOOL_F));
- return CDR (ret);
-}
+ for (; scm_is_pair (exps); exps = CDR (exps))
+ inits = scm_cons (memoize (CAR (exps), new_env), inits);
+ inits = scm_reverse_x (inits, SCM_UNDEFINED);
-static SCM
-scm_m_quote (SCM expr, SCM env SCM_UNUSED)
-{
- SCM quotee;
+ return MAKMEMO_LET
+ (undefs,
+ MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)),
+ memoize (body, new_env))));
+ }
- const SCM cdr_expr = CDR (expr);
- 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 MAKMEMO_QUOTE (quotee);
-}
+ case SCM_EXPANDED_DYNLET:
+ return MAKMEMO_WITH_FLUIDS (memoize_exps (REF (exp, DYNLET, FLUIDS), env),
+ memoize_exps (REF (exp, DYNLET, VALS), env),
+ memoize (REF (exp, DYNLET, BODY), env));
-static SCM
-scm_m_set_x (SCM expr, SCM env)
-{
- SCM variable;
- SCM vmem;
-
- const SCM cdr_expr = CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
- variable = CAR (cdr_expr);
- vmem = memoize (variable, env);
-
- switch (SCM_MEMOIZED_TAG (vmem))
- {
- case SCM_M_LEXICAL_REF:
- return MAKMEMO_LEX_SET (SCM_I_INUM (SCM_MEMOIZED_ARGS (vmem)),
- memoize (CADDR (expr), env));
- case SCM_M_TOPLEVEL_REF:
- return MAKMEMO_TOP_SET (variable,
- memoize (CADDR (expr), env));
- case SCM_M_MODULE_REF:
- return MAKMEMO_MOD_SET (memoize (CADDR (expr), env),
- CAR (SCM_MEMOIZED_ARGS (vmem)),
- CADR (SCM_MEMOIZED_ARGS (vmem)),
- CDDR (SCM_MEMOIZED_ARGS (vmem)));
default:
- syntax_error (s_bad_variable, variable, expr);
+ abort ();
}
}
@@ -1260,6 +404,8 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
"Memoize the expression @var{exp}.")
#define FUNC_NAME s_scm_memoize_expression
{
+ if (!SCM_EXPANDED_P (exp))
+ exp = scm_macroexpand (exp);
return memoize (exp, scm_current_module ());
}
#undef FUNC_NAME
@@ -1334,19 +480,6 @@ static SCM m_prompt (SCM tag, SCM exp, SCM handler)
}
#undef FUNC_NAME
-SCM_DEFINE (scm_memoizer_p, "memoizer?", 1, 0, 0,
- (SCM x), "")
-{
- return scm_from_bool (SCM_MEMOIZER_P (x));
-}
-
-SCM_DEFINE (scm_memoizer, "memoizer", 1, 0, 0,
- (SCM memoizer), "")
-{
- SCM_ASSERT (SCM_MEMOIZER_P (memoizer), memoizer, 1, "memoizer?");
- return SCM_MEMOIZER (memoizer);
-}
-
@@ -1672,6 +805,7 @@ scm_init_memoize ()
scm_c_define ("macroexpand",
scm_variable_ref (scm_c_lookup ("memoize-expression")));
+ list_of_guile = scm_list_1 (scm_from_locale_symbol ("guile"));
}
/*
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index e6e5f1713..460369e57 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -223,7 +223,15 @@
(define (make-general-closure env body nreq rest? nopt kw inits alt)
(define alt-proc
(and alt
- (apply make-general-closure env (memoized-expression-data alt))))
+ (let* ((body (car alt))
+ (nreq (cadr alt))
+ (rest (if (null? (cddr alt)) #f (caddr alt)))
+ (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))
+ (nopt (if tail (car tail) 0))
+ (kw (and tail (cadr tail)))
+ (inits (if tail (caddr tail) '()))
+ (alt (and tail (cadddr tail))))
+ (make-general-closure env body nreq rest nopt kw inits alt))))
(lambda %args
(let lp ((env env)
(nreq* nreq)