mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
c7d170c5d1
* NEWS: * README: * doc/r5rs/r5rs.texi: * doc/ref/api-data.texi: * doc/ref/api-debug.texi: * doc/ref/api-evaluation.texi: * doc/ref/api-io.texi: * doc/ref/api-macros.texi: * doc/ref/api-procedures.texi: * doc/ref/api-scheduling.texi: * doc/ref/api-undocumented.texi: * doc/ref/libguile-concepts.texi: * doc/ref/posix.texi: * doc/ref/srfi-modules.texi: * doc/ref/vm.texi: * doc/ref/web.texi: * examples/box-dynamic-module/box.c: * examples/box-dynamic/box.c: * examples/box-module/box.c: * examples/box/box.c: * examples/safe/safe: * examples/scripts/README: * examples/scripts/hello: * gc-benchmarks/larceny/twobit-input-long.sch: * gc-benchmarks/larceny/twobit-smaller.sch: * gc-benchmarks/larceny/twobit.sch: * libguile/expand.c: * libguile/load.c: * libguile/net_db.c: * libguile/scmsigs.c: * libguile/srfi-14.c: * libguile/threads.c: * meta/guile.m4: * module/ice-9/match.upstream.scm: * module/ice-9/ports.scm: * module/language/cps/graphs.scm: * module/scripts/doc-snarf.scm: * module/srfi/srfi-19.scm: * module/system/repl/command.scm: * test-suite/tests/srfi-18.test: Fix typos. Signed-off-by: Ludovic Courtès <ludo@gnu.org>
1664 lines
52 KiB
C
1664 lines
52 KiB
C
/* Copyright 1995-2014,2016,2018-2020
|
||
Free Software Foundation, Inc.
|
||
|
||
This file is part of Guile.
|
||
|
||
Guile 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.
|
||
|
||
Guile 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 Guile. If not, see
|
||
<https://www.gnu.org/licenses/>. */
|
||
|
||
|
||
|
||
#ifdef HAVE_CONFIG_H
|
||
# include <config.h>
|
||
#endif
|
||
|
||
#include "alist.h"
|
||
#include "boolean.h"
|
||
#include "continuations.h"
|
||
#include "eq.h"
|
||
#include "gsubr.h"
|
||
#include "hashtab.h"
|
||
#include "keywords.h"
|
||
#include "list.h"
|
||
#include "macros.h"
|
||
#include "memoize.h" /* for the SCM_API declarations of 'scm_sym_' */
|
||
#include "modules.h"
|
||
#include "pairs.h"
|
||
#include "ports.h"
|
||
#include "print.h"
|
||
#include "srcprop.h"
|
||
#include "strings.h"
|
||
#include "symbols.h"
|
||
#include "throw.h"
|
||
#include "variable.h"
|
||
#include "vectors.h"
|
||
|
||
#include "expand.h"
|
||
|
||
|
||
|
||
|
||
|
||
SCM scm_exp_vtable_vtable;
|
||
static SCM exp_vtables[SCM_NUM_EXPANDED_TYPES];
|
||
static size_t exp_nfields[SCM_NUM_EXPANDED_TYPES];
|
||
static SCM const_unbound;
|
||
static const char* exp_names[SCM_NUM_EXPANDED_TYPES];
|
||
static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
|
||
|
||
|
||
/* The trailing underscores on these first to are to avoid spurious
|
||
conflicts with macros defined on MinGW. */
|
||
|
||
#define VOID_(src) \
|
||
SCM_MAKE_EXPANDED_VOID(src)
|
||
#define CONST_(src, exp) \
|
||
SCM_MAKE_EXPANDED_CONST(src, exp)
|
||
#define PRIMITIVE_REF(src, name) \
|
||
SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name)
|
||
#define LEXICAL_REF(src, name, gensym) \
|
||
SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
|
||
#define LEXICAL_SET(src, name, gensym, exp) \
|
||
SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp)
|
||
#define MODULE_REF(src, mod, name, public) \
|
||
SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public)
|
||
#define MODULE_SET(src, mod, name, public, exp) \
|
||
SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp)
|
||
#define TOPLEVEL_REF(src, mod, name) \
|
||
SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name)
|
||
#define TOPLEVEL_SET(src, mod, name, exp) \
|
||
SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp)
|
||
#define TOPLEVEL_DEFINE(src, mod, name, exp) \
|
||
SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, name, exp)
|
||
#define CONDITIONAL(src, test, consequent, alternate) \
|
||
SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
|
||
#define PRIMCALL(src, name, exps) \
|
||
SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps)
|
||
#define CALL(src, proc, exps) \
|
||
SCM_MAKE_EXPANDED_CALL(src, proc, exps)
|
||
#define SEQ(src, head, tail) \
|
||
SCM_MAKE_EXPANDED_SEQ(src, head, tail)
|
||
#define LAMBDA(src, meta, body) \
|
||
SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
|
||
#define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
|
||
SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate)
|
||
#define LET(src, names, gensyms, vals, body) \
|
||
SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
|
||
#define LETREC(src, in_order_p, names, gensyms, vals, body) \
|
||
SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
|
||
|
||
#define 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)
|
||
|
||
/* Abbreviate SCM_EXPANDED_REF. */
|
||
#define REF(x,type,field) \
|
||
(scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
|
||
|
||
|
||
static const char s_bad_expression[] = "Bad expression";
|
||
static const char s_expression[] = "Missing or extra expression in";
|
||
static const char s_missing_expression[] = "Missing expression in";
|
||
static const char s_extra_expression[] = "Extra expression 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_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_formals[] = "Bad formals";
|
||
static const char s_bad_formal[] = "Bad formal";
|
||
static const char s_duplicate_formal[] = "Duplicate formal";
|
||
|
||
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 ("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 ("letrec*", expand_letrec_star);
|
||
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_arrow, "=>");
|
||
SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
|
||
SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
|
||
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_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_SYMBOL (sym_call_with_prompt, "call-with-prompt");
|
||
SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
|
||
SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
|
||
SCM_SYMBOL (sym_lambda_star, "lambda*");
|
||
SCM_SYMBOL (sym_eval, "eval");
|
||
SCM_SYMBOL (sym_load, "load");
|
||
SCM_SYMBOL (sym_primitive, "primitive");
|
||
|
||
SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
|
||
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
|
||
SCM_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_utf8_string (msg);
|
||
SCM filename = SCM_BOOL_F;
|
||
SCM linenr = SCM_BOOL_F;
|
||
const char *format;
|
||
SCM args;
|
||
|
||
if (scm_is_pair (form))
|
||
{
|
||
filename = scm_source_property (form, scm_sym_filename);
|
||
linenr = scm_source_property (form, scm_sym_line);
|
||
}
|
||
|
||
if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
|
||
{
|
||
filename = scm_source_property (expr, scm_sym_filename);
|
||
linenr = scm_source_property (expr, scm_sym_line);
|
||
}
|
||
|
||
if (!SCM_UNBNDP (expr))
|
||
{
|
||
if (scm_is_true (filename))
|
||
{
|
||
format = "In file ~S, line ~S: ~A ~S in expression ~S.";
|
||
args = scm_list_5 (filename, linenr, msg_string, form, expr);
|
||
}
|
||
else if (scm_is_true (linenr))
|
||
{
|
||
format = "In line ~S: ~A ~S in expression ~S.";
|
||
args = scm_list_4 (linenr, msg_string, form, expr);
|
||
}
|
||
else
|
||
{
|
||
format = "~A ~S in expression ~S.";
|
||
args = scm_list_3 (msg_string, form, expr);
|
||
}
|
||
}
|
||
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 = expand (CAR (exp), env);
|
||
|
||
for (arg_exps = CDR (exp); scm_is_pair (arg_exps);
|
||
arg_exps = CDR (arg_exps))
|
||
args = scm_cons (expand (CAR (arg_exps), env), args);
|
||
args = scm_reverse_x (args, SCM_UNDEFINED);
|
||
|
||
if (!scm_is_null (arg_exps))
|
||
syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
|
||
|
||
if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF)
|
||
return PRIMCALL (scm_source_properties (exp),
|
||
SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
|
||
args);
|
||
else
|
||
return CALL (scm_source_properties (exp), proc, args);
|
||
}
|
||
}
|
||
else if (scm_is_symbol (exp))
|
||
{
|
||
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, 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 SEQ (scm_source_properties (forms),
|
||
expand (CAR (forms), env),
|
||
expand_sequence (CDR (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_is_symbol (CADDR (expr)), s_bad_expression, expr);
|
||
|
||
if (scm_is_eq (CADR (expr), sym_primitive))
|
||
return PRIMITIVE_REF (scm_source_properties (expr), CADDR (expr));
|
||
|
||
ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
|
||
return MODULE_REF (scm_source_properties (expr),
|
||
CADR (expr), CADDR (expr), SCM_BOOL_F);
|
||
}
|
||
|
||
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_utf8_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),
|
||
CALL (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),
|
||
SCM_BOOL_F,
|
||
CAR (variable),
|
||
expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)),
|
||
env));
|
||
}
|
||
ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
|
||
ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
|
||
return TOPLEVEL_DEFINE (scm_source_properties (expr), SCM_BOOL_F, variable,
|
||
expand (CAR (body), 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;
|
||
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
|
||
expander, 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-canon list */
|
||
if (scm_is_null (kw))
|
||
kw = SCM_BOOL_F;
|
||
else
|
||
{
|
||
SCM kw_canon = 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);
|
||
|
||
inits = scm_cons (expand (init, env), inits);
|
||
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
|
||
kw_canon = scm_cons (scm_list_3 (k, sym, CAR (vars)), kw_canon);
|
||
env = scm_acons (sym, CAR (vars), env);
|
||
}
|
||
kw_canon = scm_reverse_x (kw_canon, SCM_UNDEFINED);
|
||
kw = scm_cons (allow_other_keys, kw_canon);
|
||
}
|
||
|
||
/* We should check for no duplicates, but given that psyntax does this
|
||
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 signaled. */
|
||
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_BOOL_F,
|
||
scm_list_1 (name), scm_list_1 (name_sym),
|
||
scm_list_1 (LAMBDA (SCM_BOOL_F,
|
||
SCM_EOL,
|
||
LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F,
|
||
SCM_BOOL_F, SCM_EOL, var_syms,
|
||
expand_sequence (CDDDR (expr), inner_env),
|
||
SCM_BOOL_F))),
|
||
CALL (SCM_BOOL_F,
|
||
LEXICAL_REF (SCM_BOOL_F, name, name_sym),
|
||
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_helper (SCM expr, SCM env, SCM in_order_p)
|
||
{
|
||
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, in_order_p,
|
||
var_names, var_syms, expand_exprs (inits, env),
|
||
expand_sequence (CDDR (expr), env));
|
||
}
|
||
}
|
||
|
||
static SCM
|
||
expand_letrec (SCM expr, SCM env)
|
||
{
|
||
return expand_letrec_helper (expr, env, SCM_BOOL_F);
|
||
}
|
||
|
||
static SCM
|
||
expand_letrec_star (SCM expr, SCM env)
|
||
{
|
||
return expand_letrec_helper (expr, env, SCM_BOOL_T);
|
||
}
|
||
|
||
static SCM
|
||
expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
|
||
{
|
||
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, MOD),
|
||
SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME),
|
||
expand (CADDR (expr), env));
|
||
case SCM_EXPANDED_MODULE_REF:
|
||
return MODULE_SET (scm_source_properties (expr),
|
||
SCM_EXPANDED_REF (vmem, MODULE_REF, MOD),
|
||
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);
|
||
}
|
||
}
|
||
|
||
|
||
|
||
|
||
/* This is the boot expander. It is later replaced with psyntax's sc-expand. */
|
||
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
|
||
|
||
SCM_DEFINE (scm_macroexpanded_p, "macroexpanded?", 1, 0, 0,
|
||
(SCM exp),
|
||
"Return @code{#t} if @var{exp} is an expanded expression.")
|
||
#define FUNC_NAME s_scm_macroexpanded_p
|
||
{
|
||
return scm_from_bool (SCM_EXPANDED_P (exp));
|
||
}
|
||
#undef FUNC_NAME
|
||
|
||
|
||
|
||
|
||
static void
|
||
compute_assigned (SCM exp, SCM assigned)
|
||
{
|
||
if (scm_is_null (exp) || scm_is_false (exp))
|
||
return;
|
||
|
||
if (scm_is_pair (exp))
|
||
{
|
||
compute_assigned (CAR (exp), assigned);
|
||
compute_assigned (CDR (exp), assigned);
|
||
return;
|
||
}
|
||
|
||
if (!SCM_EXPANDED_P (exp))
|
||
abort ();
|
||
|
||
switch (SCM_EXPANDED_TYPE (exp))
|
||
{
|
||
case SCM_EXPANDED_VOID:
|
||
case SCM_EXPANDED_CONST:
|
||
case SCM_EXPANDED_PRIMITIVE_REF:
|
||
case SCM_EXPANDED_LEXICAL_REF:
|
||
case SCM_EXPANDED_MODULE_REF:
|
||
case SCM_EXPANDED_TOPLEVEL_REF:
|
||
return;
|
||
|
||
case SCM_EXPANDED_LEXICAL_SET:
|
||
scm_hashq_set_x (assigned, REF (exp, LEXICAL_SET, GENSYM), SCM_BOOL_T);
|
||
compute_assigned (REF (exp, LEXICAL_SET, EXP), assigned);
|
||
return;
|
||
|
||
case SCM_EXPANDED_MODULE_SET:
|
||
compute_assigned (REF (exp, MODULE_SET, EXP), assigned);
|
||
return;
|
||
|
||
case SCM_EXPANDED_TOPLEVEL_SET:
|
||
compute_assigned (REF (exp, TOPLEVEL_SET, EXP), assigned);
|
||
return;
|
||
|
||
case SCM_EXPANDED_TOPLEVEL_DEFINE:
|
||
compute_assigned (REF (exp, TOPLEVEL_DEFINE, EXP), assigned);
|
||
return;
|
||
|
||
case SCM_EXPANDED_CONDITIONAL:
|
||
compute_assigned (REF (exp, CONDITIONAL, TEST), assigned);
|
||
compute_assigned (REF (exp, CONDITIONAL, CONSEQUENT), assigned);
|
||
compute_assigned (REF (exp, CONDITIONAL, ALTERNATE), assigned);
|
||
return;
|
||
|
||
case SCM_EXPANDED_CALL:
|
||
compute_assigned (REF (exp, CALL, PROC), assigned);
|
||
compute_assigned (REF (exp, CALL, ARGS), assigned);
|
||
return;
|
||
|
||
case SCM_EXPANDED_PRIMCALL:
|
||
compute_assigned (REF (exp, PRIMCALL, ARGS), assigned);
|
||
return;
|
||
|
||
case SCM_EXPANDED_SEQ:
|
||
compute_assigned (REF (exp, SEQ, HEAD), assigned);
|
||
compute_assigned (REF (exp, SEQ, TAIL), assigned);
|
||
return;
|
||
|
||
case SCM_EXPANDED_LAMBDA:
|
||
compute_assigned (REF (exp, LAMBDA, BODY), assigned);
|
||
return;
|
||
|
||
case SCM_EXPANDED_LAMBDA_CASE:
|
||
compute_assigned (REF (exp, LAMBDA_CASE, INITS), assigned);
|
||
compute_assigned (REF (exp, LAMBDA_CASE, BODY), assigned);
|
||
compute_assigned (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
|
||
return;
|
||
|
||
case SCM_EXPANDED_LET:
|
||
compute_assigned (REF (exp, LET, VALS), assigned);
|
||
compute_assigned (REF (exp, LET, BODY), assigned);
|
||
return;
|
||
|
||
case SCM_EXPANDED_LETREC:
|
||
{
|
||
SCM syms = REF (exp, LETREC, GENSYMS);
|
||
/* We lower letrec in this same pass, so mark these variables as
|
||
assigned. */
|
||
for (; scm_is_pair (syms); syms = CDR (syms))
|
||
scm_hashq_set_x (assigned, CAR (syms), SCM_BOOL_T);
|
||
}
|
||
compute_assigned (REF (exp, LETREC, VALS), assigned);
|
||
compute_assigned (REF (exp, LETREC, BODY), assigned);
|
||
return;
|
||
|
||
default:
|
||
abort ();
|
||
}
|
||
}
|
||
|
||
static SCM
|
||
box_value (SCM exp)
|
||
{
|
||
return PRIMCALL (SCM_BOOL_F, scm_from_latin1_symbol ("make-variable"),
|
||
scm_list_1 (exp));
|
||
}
|
||
|
||
static SCM
|
||
box_lexical (SCM name, SCM sym)
|
||
{
|
||
return LEXICAL_SET (SCM_BOOL_F, name, sym,
|
||
box_value (LEXICAL_REF (SCM_BOOL_F, name, sym)));
|
||
}
|
||
|
||
static SCM
|
||
init_if_unbound (SCM src, SCM name, SCM sym, SCM init)
|
||
{
|
||
return CONDITIONAL (src,
|
||
PRIMCALL (src,
|
||
scm_from_latin1_symbol ("eq?"),
|
||
scm_list_2 (LEXICAL_REF (src, name, sym),
|
||
const_unbound)),
|
||
LEXICAL_SET (src, name, sym, init),
|
||
VOID_ (src));
|
||
}
|
||
|
||
static SCM
|
||
init_boxes (SCM names, SCM syms, SCM vals, SCM body)
|
||
{
|
||
if (scm_is_null (names)) return body;
|
||
|
||
return SEQ (SCM_BOOL_F,
|
||
PRIMCALL
|
||
(SCM_BOOL_F,
|
||
scm_from_latin1_symbol ("variable-set!"),
|
||
scm_list_2 (LEXICAL_REF (SCM_BOOL_F, CAR (names), CAR (syms)),
|
||
CAR (vals))),
|
||
init_boxes (CDR (names), CDR (syms), CDR (vals), body));
|
||
}
|
||
|
||
static SCM
|
||
convert_assignment (SCM exp, SCM assigned)
|
||
{
|
||
if (scm_is_null (exp) || scm_is_false (exp))
|
||
return exp;
|
||
|
||
if (scm_is_pair (exp))
|
||
return scm_cons (convert_assignment (CAR (exp), assigned),
|
||
convert_assignment (CDR (exp), assigned));
|
||
|
||
if (!SCM_EXPANDED_P (exp))
|
||
abort ();
|
||
|
||
switch (SCM_EXPANDED_TYPE (exp))
|
||
{
|
||
case SCM_EXPANDED_VOID:
|
||
case SCM_EXPANDED_CONST:
|
||
case SCM_EXPANDED_PRIMITIVE_REF:
|
||
case SCM_EXPANDED_MODULE_REF:
|
||
case SCM_EXPANDED_TOPLEVEL_REF:
|
||
return exp;
|
||
|
||
case SCM_EXPANDED_LEXICAL_REF:
|
||
{
|
||
SCM sym = REF (exp, LEXICAL_REF, GENSYM);
|
||
|
||
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
|
||
return PRIMCALL
|
||
(REF (exp, LEXICAL_REF, SRC),
|
||
scm_from_latin1_symbol ("variable-ref"),
|
||
scm_list_1 (exp));
|
||
return exp;
|
||
}
|
||
|
||
case SCM_EXPANDED_LEXICAL_SET:
|
||
return PRIMCALL
|
||
(REF (exp, LEXICAL_SET, SRC),
|
||
scm_from_latin1_symbol ("variable-set!"),
|
||
scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, SRC),
|
||
REF (exp, LEXICAL_SET, NAME),
|
||
REF (exp, LEXICAL_SET, GENSYM)),
|
||
convert_assignment (REF (exp, LEXICAL_SET, EXP),
|
||
assigned)));
|
||
|
||
case SCM_EXPANDED_MODULE_SET:
|
||
return MODULE_SET
|
||
(REF (exp, MODULE_SET, SRC),
|
||
REF (exp, MODULE_SET, MOD),
|
||
REF (exp, MODULE_SET, NAME),
|
||
REF (exp, MODULE_SET, PUBLIC),
|
||
convert_assignment (REF (exp, MODULE_SET, EXP), assigned));
|
||
|
||
case SCM_EXPANDED_TOPLEVEL_SET:
|
||
return TOPLEVEL_SET
|
||
(REF (exp, TOPLEVEL_SET, SRC),
|
||
REF (exp, TOPLEVEL_SET, MOD),
|
||
REF (exp, TOPLEVEL_SET, NAME),
|
||
convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned));
|
||
|
||
case SCM_EXPANDED_TOPLEVEL_DEFINE:
|
||
return TOPLEVEL_DEFINE
|
||
(REF (exp, TOPLEVEL_DEFINE, SRC),
|
||
REF (exp, TOPLEVEL_DEFINE, MOD),
|
||
REF (exp, TOPLEVEL_DEFINE, NAME),
|
||
convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP),
|
||
assigned));
|
||
|
||
case SCM_EXPANDED_CONDITIONAL:
|
||
return CONDITIONAL
|
||
(REF (exp, CONDITIONAL, SRC),
|
||
convert_assignment (REF (exp, CONDITIONAL, TEST), assigned),
|
||
convert_assignment (REF (exp, CONDITIONAL, CONSEQUENT), assigned),
|
||
convert_assignment (REF (exp, CONDITIONAL, ALTERNATE), assigned));
|
||
|
||
case SCM_EXPANDED_CALL:
|
||
return CALL
|
||
(REF (exp, CALL, SRC),
|
||
convert_assignment (REF (exp, CALL, PROC), assigned),
|
||
convert_assignment (REF (exp, CALL, ARGS), assigned));
|
||
|
||
case SCM_EXPANDED_PRIMCALL:
|
||
return PRIMCALL
|
||
(REF (exp, PRIMCALL, SRC),
|
||
REF (exp, PRIMCALL, NAME),
|
||
convert_assignment (REF (exp, PRIMCALL, ARGS), assigned));
|
||
|
||
case SCM_EXPANDED_SEQ:
|
||
return SEQ
|
||
(REF (exp, SEQ, SRC),
|
||
convert_assignment (REF (exp, SEQ, HEAD), assigned),
|
||
convert_assignment (REF (exp, SEQ, TAIL), assigned));
|
||
|
||
case SCM_EXPANDED_LAMBDA:
|
||
return LAMBDA
|
||
(REF (exp, LAMBDA, SRC),
|
||
REF (exp, LAMBDA, META),
|
||
scm_is_false (REF (exp, LAMBDA, BODY))
|
||
/* Give a body to case-lambda with no clauses. */
|
||
? LAMBDA_CASE (SCM_BOOL_F, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F,
|
||
SCM_EOL, SCM_EOL,
|
||
PRIMCALL
|
||
(SCM_BOOL_F,
|
||
scm_from_latin1_symbol ("throw"),
|
||
scm_list_5 (CONST_ (SCM_BOOL_F, scm_args_number_key),
|
||
CONST_ (SCM_BOOL_F, SCM_BOOL_F),
|
||
CONST_ (SCM_BOOL_F, scm_from_latin1_string
|
||
("Wrong number of arguments")),
|
||
CONST_ (SCM_BOOL_F, SCM_EOL),
|
||
CONST_ (SCM_BOOL_F, SCM_BOOL_F))),
|
||
SCM_BOOL_F)
|
||
: convert_assignment (REF (exp, LAMBDA, BODY), assigned));
|
||
|
||
case SCM_EXPANDED_LAMBDA_CASE:
|
||
{
|
||
SCM src, req, opt, rest, kw, inits, syms, body, alt;
|
||
SCM namewalk, symwalk, new_inits, seq;
|
||
|
||
/* Box assigned formals. Since initializers can capture
|
||
previous formals, we convert initializers to be in the body
|
||
instead of in the "header". */
|
||
|
||
src = REF (exp, LAMBDA_CASE, SRC);
|
||
req = REF (exp, LAMBDA_CASE, REQ);
|
||
opt = REF (exp, LAMBDA_CASE, OPT);
|
||
rest = REF (exp, LAMBDA_CASE, REST);
|
||
kw = REF (exp, LAMBDA_CASE, KW);
|
||
inits = convert_assignment (REF (exp, LAMBDA_CASE, INITS), assigned);
|
||
syms = REF (exp, LAMBDA_CASE, GENSYMS);
|
||
body = convert_assignment (REF (exp, LAMBDA_CASE, BODY), assigned);
|
||
alt = convert_assignment (REF (exp, LAMBDA_CASE, ALTERNATE), assigned);
|
||
|
||
new_inits = scm_make_list (scm_length (inits), const_unbound);
|
||
|
||
seq = SCM_EOL, symwalk = syms;
|
||
|
||
/* Required arguments may need boxing. */
|
||
for (namewalk = req;
|
||
scm_is_pair (namewalk);
|
||
namewalk = CDR (namewalk), symwalk = CDR (symwalk))
|
||
{
|
||
SCM name = CAR (namewalk), sym = CAR (symwalk);
|
||
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
|
||
seq = scm_cons (box_lexical (name, sym), seq);
|
||
}
|
||
/* Optional arguments may need initialization and/or boxing. */
|
||
for (namewalk = opt;
|
||
scm_is_pair (namewalk);
|
||
namewalk = CDR (namewalk), symwalk = CDR (symwalk),
|
||
inits = CDR (inits))
|
||
{
|
||
SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (inits);
|
||
seq = scm_cons (init_if_unbound (src, name, sym, init), seq);
|
||
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
|
||
seq = scm_cons (box_lexical (name, sym), seq);
|
||
}
|
||
/* Rest arguments may need boxing. */
|
||
if (scm_is_true (rest))
|
||
{
|
||
SCM sym = CAR (symwalk);
|
||
symwalk = CDR (symwalk);
|
||
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
|
||
seq = scm_cons (box_lexical (rest, sym), seq);
|
||
}
|
||
/* The rest of the arguments, if any, are keyword arguments,
|
||
which may need initialization and/or boxing. */
|
||
for (;
|
||
scm_is_pair (symwalk);
|
||
symwalk = CDR (symwalk), inits = CDR (inits))
|
||
{
|
||
SCM sym = CAR (symwalk), init = CAR (inits);
|
||
seq = scm_cons (init_if_unbound (src, SCM_BOOL_F, sym, init), seq);
|
||
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
|
||
seq = scm_cons (box_lexical (SCM_BOOL_F, sym), seq);
|
||
}
|
||
|
||
for (; scm_is_pair (seq); seq = CDR (seq))
|
||
body = SEQ (src, CAR (seq), body);
|
||
|
||
return LAMBDA_CASE
|
||
(src, req, opt, rest, kw, new_inits, syms, body, alt);
|
||
}
|
||
|
||
case SCM_EXPANDED_LET:
|
||
{
|
||
SCM src, names, syms, vals, body, new_vals, walk;
|
||
|
||
src = REF (exp, LET, SRC);
|
||
names = REF (exp, LET, NAMES);
|
||
syms = REF (exp, LET, GENSYMS);
|
||
vals = convert_assignment (REF (exp, LET, VALS), assigned);
|
||
body = convert_assignment (REF (exp, LET, BODY), assigned);
|
||
|
||
for (new_vals = SCM_EOL, walk = syms;
|
||
scm_is_pair (vals);
|
||
vals = CDR (vals), walk = CDR (walk))
|
||
{
|
||
SCM sym = CAR (walk), val = CAR (vals);
|
||
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
|
||
new_vals = scm_cons (box_value (val), new_vals);
|
||
else
|
||
new_vals = scm_cons (val, new_vals);
|
||
}
|
||
new_vals = scm_reverse (new_vals);
|
||
|
||
return LET (src, names, syms, new_vals, body);
|
||
}
|
||
|
||
case SCM_EXPANDED_LETREC:
|
||
{
|
||
SCM src, names, syms, vals, empty_box, boxes, body;
|
||
|
||
src = REF (exp, LETREC, SRC);
|
||
names = REF (exp, LETREC, NAMES);
|
||
syms = REF (exp, LETREC, GENSYMS);
|
||
vals = convert_assignment (REF (exp, LETREC, VALS), assigned);
|
||
body = convert_assignment (REF (exp, LETREC, BODY), assigned);
|
||
|
||
empty_box =
|
||
PRIMCALL (SCM_BOOL_F,
|
||
scm_from_latin1_symbol ("make-undefined-variable"),
|
||
SCM_EOL);
|
||
boxes = scm_make_list (scm_length (names), empty_box);
|
||
|
||
if (scm_is_true (REF (exp, LETREC, IN_ORDER_P)))
|
||
return LET
|
||
(src, names, syms, boxes,
|
||
init_boxes (names, syms, vals, body));
|
||
else
|
||
{
|
||
SCM walk, tmps = SCM_EOL, inits = SCM_EOL;
|
||
|
||
for (walk = syms; scm_is_pair (walk); walk = CDR (walk))
|
||
{
|
||
SCM tmp = scm_gensym (SCM_UNDEFINED);
|
||
tmps = scm_cons (tmp, tmps);
|
||
inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, SCM_BOOL_F, tmp),
|
||
inits);
|
||
}
|
||
tmps = scm_reverse (tmps);
|
||
inits = scm_reverse (inits);
|
||
|
||
return LET
|
||
(src, names, syms, boxes,
|
||
SEQ (src,
|
||
LET (src, names, tmps, vals,
|
||
init_boxes (names, syms, inits, VOID_ (src))),
|
||
body));
|
||
}
|
||
}
|
||
|
||
default:
|
||
abort ();
|
||
}
|
||
}
|
||
|
||
SCM
|
||
scm_convert_assignment (SCM exp)
|
||
{
|
||
SCM assigned = scm_c_make_hash_table (0);
|
||
|
||
compute_assigned (exp, assigned);
|
||
return convert_assignment (exp, assigned);
|
||
}
|
||
|
||
|
||
|
||
|
||
#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_utf8_string ("pw"))));
|
||
printer = SCM_BOOL_F;
|
||
name = scm_from_utf8_symbol (exp_names[n]);
|
||
code = scm_from_size_t (n);
|
||
fields = SCM_EOL;
|
||
{
|
||
size_t m = exp_nfields[n];
|
||
while (m--)
|
||
fields = scm_cons (scm_from_utf8_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 (CALL);
|
||
DEFINE_NAMES (PRIMCALL);
|
||
DEFINE_NAMES (SEQ);
|
||
DEFINE_NAMES (LAMBDA);
|
||
DEFINE_NAMES (LAMBDA_CASE);
|
||
DEFINE_NAMES (LET);
|
||
DEFINE_NAMES (LETREC);
|
||
|
||
scm_exp_vtable_vtable =
|
||
scm_make_vtable (scm_from_utf8_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);
|
||
|
||
const_unbound =
|
||
CONST_ (SCM_BOOL_F, scm_list_1 (scm_from_latin1_symbol ("unbound")));
|
||
|
||
scm_c_define_gsubr ("convert-assignment", 1, 0, 0, scm_convert_assignment);
|
||
|
||
scm_c_define ("%expanded-vtables", scm_vector (exp_vtable_list));
|
||
|
||
#include "expand.x"
|
||
}
|