mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-02 02:10:19 +02:00
Boot expander no longer tracks source positions
* libguile/expand.c (VOID_, CONST_, PRIMITIVE_REF, LEXICAL_REF) (LEXICAL_SET, MODULE_REF, MODULE_SET, TOPLEVEL_REF, TOPLEVEL_SET) (TOPLEVEL_DEFINE, CONDITIONAL, PRIMCALL, CALL, SEQ, LAMBDA, LAMBDA_CASE) (LET, LETREC): Always pass #f as the source. Source locations are instead handled by psyntax. Adapt all callers.
This commit is contained in:
Andy Wingo
parent
9ab8f3d807
commit
71d112cdde
1 changed files with 130 additions and 225 deletions
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright 1995-2014,2016,2018-2020
|
||||
/* Copyright 1995-2014,2016,2018-2020,2025
|
||||
Free Software Foundation, Inc.
|
||||
|
||||
This file is part of Guile.
|
||||
|
|
@ -37,7 +37,6 @@
|
|||
#include "pairs.h"
|
||||
#include "ports.h"
|
||||
#include "print.h"
|
||||
#include "srcprop.h"
|
||||
#include "strings.h"
|
||||
#include "symbols.h"
|
||||
#include "throw.h"
|
||||
|
|
@ -61,42 +60,42 @@ static const char** exp_field_names[SCM_NUM_EXPANDED_TYPES];
|
|||
/* The trailing underscores on these first to are to avoid spurious
|
||||
conflicts with macros defined on MinGW. */
|
||||
|
||||
#define VOID_(src) \
|
||||
SCM_MAKE_EXPANDED_VOID(src)
|
||||
#define CONST_(src, exp) \
|
||||
SCM_MAKE_EXPANDED_CONST(src, exp)
|
||||
#define PRIMITIVE_REF(src, name) \
|
||||
SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name)
|
||||
#define LEXICAL_REF(src, name, gensym) \
|
||||
SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym)
|
||||
#define LEXICAL_SET(src, name, gensym, exp) \
|
||||
SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp)
|
||||
#define MODULE_REF(src, mod, name, public) \
|
||||
SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public)
|
||||
#define MODULE_SET(src, mod, name, public, exp) \
|
||||
SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp)
|
||||
#define TOPLEVEL_REF(src, mod, name) \
|
||||
SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name)
|
||||
#define TOPLEVEL_SET(src, mod, name, exp) \
|
||||
SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp)
|
||||
#define TOPLEVEL_DEFINE(src, mod, name, exp) \
|
||||
SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, name, exp)
|
||||
#define CONDITIONAL(src, test, consequent, alternate) \
|
||||
SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate)
|
||||
#define PRIMCALL(src, name, exps) \
|
||||
SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps)
|
||||
#define CALL(src, proc, exps) \
|
||||
SCM_MAKE_EXPANDED_CALL(src, proc, exps)
|
||||
#define SEQ(src, head, tail) \
|
||||
SCM_MAKE_EXPANDED_SEQ(src, head, tail)
|
||||
#define LAMBDA(src, meta, body) \
|
||||
SCM_MAKE_EXPANDED_LAMBDA(src, meta, body)
|
||||
#define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \
|
||||
SCM_MAKE_EXPANDED_LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate)
|
||||
#define LET(src, names, gensyms, vals, body) \
|
||||
SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body)
|
||||
#define LETREC(src, in_order_p, names, gensyms, vals, body) \
|
||||
SCM_MAKE_EXPANDED_LETREC(src, in_order_p, names, gensyms, vals, body)
|
||||
#define VOID_() \
|
||||
SCM_MAKE_EXPANDED_VOID(SCM_BOOL_F)
|
||||
#define CONST_(exp) \
|
||||
SCM_MAKE_EXPANDED_CONST(SCM_BOOL_F, exp)
|
||||
#define PRIMITIVE_REF(name) \
|
||||
SCM_MAKE_EXPANDED_PRIMITIVE_REF(SCM_BOOL_F, name)
|
||||
#define LEXICAL_REF(name, gensym) \
|
||||
SCM_MAKE_EXPANDED_LEXICAL_REF(SCM_BOOL_F, name, gensym)
|
||||
#define LEXICAL_SET(name, gensym, exp) \
|
||||
SCM_MAKE_EXPANDED_LEXICAL_SET(SCM_BOOL_F, name, gensym, exp)
|
||||
#define MODULE_REF(mod, name, public) \
|
||||
SCM_MAKE_EXPANDED_MODULE_REF(SCM_BOOL_F, mod, name, public)
|
||||
#define MODULE_SET(mod, name, public, exp) \
|
||||
SCM_MAKE_EXPANDED_MODULE_SET(SCM_BOOL_F, mod, name, public, exp)
|
||||
#define TOPLEVEL_REF(mod, name) \
|
||||
SCM_MAKE_EXPANDED_TOPLEVEL_REF(SCM_BOOL_F, mod, name)
|
||||
#define TOPLEVEL_SET(mod, name, exp) \
|
||||
SCM_MAKE_EXPANDED_TOPLEVEL_SET(SCM_BOOL_F, mod, name, exp)
|
||||
#define TOPLEVEL_DEFINE(mod, name, exp) \
|
||||
SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(SCM_BOOL_F, mod, name, exp)
|
||||
#define CONDITIONAL(test, consequent, alternate) \
|
||||
SCM_MAKE_EXPANDED_CONDITIONAL(SCM_BOOL_F, test, consequent, alternate)
|
||||
#define PRIMCALL(name, exps) \
|
||||
SCM_MAKE_EXPANDED_PRIMCALL(SCM_BOOL_F, name, exps)
|
||||
#define CALL(proc, exps) \
|
||||
SCM_MAKE_EXPANDED_CALL(SCM_BOOL_F, proc, exps)
|
||||
#define SEQ(head, tail) \
|
||||
SCM_MAKE_EXPANDED_SEQ(SCM_BOOL_F, head, tail)
|
||||
#define LAMBDA(meta, body) \
|
||||
SCM_MAKE_EXPANDED_LAMBDA(SCM_BOOL_F, meta, body)
|
||||
#define LAMBDA_CASE(req, opt, rest, kw, inits, gensyms, body, alternate) \
|
||||
SCM_MAKE_EXPANDED_LAMBDA_CASE(SCM_BOOL_F, req, opt, rest, kw, inits, gensyms, body, alternate)
|
||||
#define LET(names, gensyms, vals, body) \
|
||||
SCM_MAKE_EXPANDED_LET(SCM_BOOL_F, names, gensyms, vals, body)
|
||||
#define LETREC(in_order_p, names, gensyms, vals, body) \
|
||||
SCM_MAKE_EXPANDED_LETREC(SCM_BOOL_F, in_order_p, names, gensyms, vals, body)
|
||||
|
||||
#define CAR(x) SCM_CAR(x)
|
||||
#define CDR(x) SCM_CDR(x)
|
||||
|
|
@ -213,71 +212,22 @@ SCM_KEYWORD (kw_rest, "rest");
|
|||
|
||||
|
||||
|
||||
/* Signal a syntax error. We distinguish between the form that caused the
|
||||
* error and the enclosing expression. The error message will print out as
|
||||
* shown in the following pattern. The file name and line number are only
|
||||
* given when they can be determined from the erroneous form or from the
|
||||
* enclosing expression.
|
||||
*
|
||||
* <filename>: In procedure memoization:
|
||||
* <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
|
||||
|
||||
static void
|
||||
syntax_error (const char* const msg, const SCM form, const SCM expr)
|
||||
{
|
||||
SCM msg_string = scm_from_utf8_string (msg);
|
||||
SCM filename = SCM_BOOL_F;
|
||||
SCM linenr = SCM_BOOL_F;
|
||||
const char *format;
|
||||
SCM args;
|
||||
|
||||
if (scm_is_pair (form))
|
||||
{
|
||||
filename = scm_source_property (form, scm_sym_filename);
|
||||
linenr = scm_source_property (form, scm_sym_line);
|
||||
}
|
||||
|
||||
if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
|
||||
{
|
||||
filename = scm_source_property (expr, scm_sym_filename);
|
||||
linenr = scm_source_property (expr, scm_sym_line);
|
||||
}
|
||||
|
||||
if (!SCM_UNBNDP (expr))
|
||||
{
|
||||
if (scm_is_true (filename))
|
||||
{
|
||||
format = "In file ~S, line ~S: ~A ~S in expression ~S.";
|
||||
args = scm_list_5 (filename, linenr, msg_string, form, expr);
|
||||
}
|
||||
else if (scm_is_true (linenr))
|
||||
{
|
||||
format = "In line ~S: ~A ~S in expression ~S.";
|
||||
args = scm_list_4 (linenr, msg_string, form, expr);
|
||||
}
|
||||
else
|
||||
{
|
||||
format = "~A ~S in expression ~S.";
|
||||
args = scm_list_3 (msg_string, form, expr);
|
||||
}
|
||||
format = "~A ~S in expression ~S.";
|
||||
args = scm_list_3 (msg_string, form, expr);
|
||||
}
|
||||
else
|
||||
{
|
||||
if (scm_is_true (filename))
|
||||
{
|
||||
format = "In file ~S, line ~S: ~A ~S.";
|
||||
args = scm_list_4 (filename, linenr, msg_string, form);
|
||||
}
|
||||
else if (scm_is_true (linenr))
|
||||
{
|
||||
format = "In line ~S: ~A ~S.";
|
||||
args = scm_list_3 (linenr, msg_string, form);
|
||||
}
|
||||
else
|
||||
{
|
||||
format = "~A ~S.";
|
||||
args = scm_list_2 (msg_string, form);
|
||||
}
|
||||
format = "~A ~S.";
|
||||
args = scm_list_2 (msg_string, form);
|
||||
}
|
||||
|
||||
scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
|
||||
|
|
@ -365,23 +315,22 @@ expand (SCM exp, SCM env)
|
|||
syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
|
||||
|
||||
if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF)
|
||||
return PRIMCALL (scm_source_properties (exp),
|
||||
SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
|
||||
return PRIMCALL (SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
|
||||
args);
|
||||
else
|
||||
return CALL (scm_source_properties (exp), proc, args);
|
||||
return CALL (proc, args);
|
||||
}
|
||||
}
|
||||
else if (scm_is_symbol (exp))
|
||||
{
|
||||
SCM gensym = expand_env_lexical_gensym (env, exp);
|
||||
if (scm_is_true (gensym))
|
||||
return LEXICAL_REF (SCM_BOOL_F, exp, gensym);
|
||||
return LEXICAL_REF (exp, gensym);
|
||||
else
|
||||
return TOPLEVEL_REF (SCM_BOOL_F, SCM_BOOL_F, exp);
|
||||
return TOPLEVEL_REF (SCM_BOOL_F, exp);
|
||||
}
|
||||
else
|
||||
return CONST_ (SCM_BOOL_F, exp);
|
||||
return CONST_ (exp);
|
||||
}
|
||||
|
||||
static SCM
|
||||
|
|
@ -402,8 +351,7 @@ expand_sequence (const SCM forms, const SCM env)
|
|||
if (scm_is_null (CDR (forms)))
|
||||
return expand (CAR (forms), env);
|
||||
else
|
||||
return SEQ (scm_source_properties (forms),
|
||||
expand (CAR (forms), env),
|
||||
return SEQ (expand (CAR (forms), env),
|
||||
expand_sequence (CDR (forms), env));
|
||||
}
|
||||
|
||||
|
|
@ -418,8 +366,7 @@ expand_at (SCM expr, SCM env SCM_UNUSED)
|
|||
ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
|
||||
ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
|
||||
|
||||
return MODULE_REF (scm_source_properties (expr),
|
||||
CADR (expr), CADDR (expr), SCM_BOOL_T);
|
||||
return MODULE_REF (CADR (expr), CADDR (expr), SCM_BOOL_T);
|
||||
}
|
||||
|
||||
static SCM
|
||||
|
|
@ -429,11 +376,10 @@ expand_atat (SCM expr, SCM env SCM_UNUSED)
|
|||
ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
|
||||
|
||||
if (scm_is_eq (CADR (expr), sym_primitive))
|
||||
return PRIMITIVE_REF (scm_source_properties (expr), CADDR (expr));
|
||||
return PRIMITIVE_REF (CADDR (expr));
|
||||
|
||||
ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
|
||||
return MODULE_REF (scm_source_properties (expr),
|
||||
CADR (expr), CADDR (expr), SCM_BOOL_F);
|
||||
return MODULE_REF (CADR (expr), CADDR (expr), SCM_BOOL_F);
|
||||
}
|
||||
|
||||
static SCM
|
||||
|
|
@ -442,17 +388,16 @@ expand_and (SCM expr, SCM env)
|
|||
const SCM cdr_expr = CDR (expr);
|
||||
|
||||
if (scm_is_null (cdr_expr))
|
||||
return CONST_ (SCM_BOOL_F, SCM_BOOL_T);
|
||||
return CONST_ (SCM_BOOL_T);
|
||||
|
||||
ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
|
||||
|
||||
if (scm_is_null (CDR (cdr_expr)))
|
||||
return expand (CAR (cdr_expr), env);
|
||||
else
|
||||
return CONDITIONAL (scm_source_properties (expr),
|
||||
expand (CAR (cdr_expr), env),
|
||||
return CONDITIONAL (expand (CAR (cdr_expr), env),
|
||||
expand_and (cdr_expr, env),
|
||||
CONST_ (SCM_BOOL_F, SCM_BOOL_F));
|
||||
CONST_ (SCM_BOOL_F));
|
||||
}
|
||||
|
||||
static SCM
|
||||
|
|
@ -480,7 +425,7 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
|
|||
}
|
||||
|
||||
if (scm_is_null (rest))
|
||||
rest = VOID_ (SCM_BOOL_F);
|
||||
rest = VOID_ ();
|
||||
else
|
||||
rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
|
||||
|
||||
|
|
@ -492,22 +437,17 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
|
|||
SCM new_env = scm_acons (tmp, tmp, env);
|
||||
ASSERT_SYNTAX (length > 2, s_missing_recipient, clause);
|
||||
ASSERT_SYNTAX (length == 3, s_extra_expression, clause);
|
||||
return LET (SCM_BOOL_F,
|
||||
scm_list_1 (tmp),
|
||||
return LET (scm_list_1 (tmp),
|
||||
scm_list_1 (tmp),
|
||||
scm_list_1 (expand (test, env)),
|
||||
CONDITIONAL (SCM_BOOL_F,
|
||||
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
|
||||
CALL (SCM_BOOL_F,
|
||||
expand (CADDR (clause), new_env),
|
||||
scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
|
||||
tmp, tmp))),
|
||||
CONDITIONAL (LEXICAL_REF (tmp, tmp),
|
||||
CALL (expand (CADDR (clause), new_env),
|
||||
scm_list_1 (LEXICAL_REF (tmp, tmp))),
|
||||
rest));
|
||||
}
|
||||
/* FIXME length == 1 case */
|
||||
else
|
||||
return CONDITIONAL (SCM_BOOL_F,
|
||||
expand (test, env),
|
||||
return CONDITIONAL (expand (test, env),
|
||||
expand_sequence (CDR (clause), env),
|
||||
rest);
|
||||
}
|
||||
|
|
@ -552,15 +492,14 @@ expand_define (SCM expr, SCM env)
|
|||
{
|
||||
ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
|
||||
return TOPLEVEL_DEFINE
|
||||
(scm_source_properties (expr),
|
||||
SCM_BOOL_F,
|
||||
(SCM_BOOL_F,
|
||||
CAR (variable),
|
||||
expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)),
|
||||
env));
|
||||
}
|
||||
ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
|
||||
ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
|
||||
return TOPLEVEL_DEFINE (scm_source_properties (expr), SCM_BOOL_F, variable,
|
||||
return TOPLEVEL_DEFINE (SCM_BOOL_F, variable,
|
||||
expand (CAR (body), env));
|
||||
}
|
||||
|
||||
|
|
@ -574,7 +513,7 @@ expand_eval_when (SCM expr, SCM env)
|
|||
|| scm_is_true (scm_memq (sym_load, CADR (expr))))
|
||||
return expand_sequence (CDDR (expr), env);
|
||||
else
|
||||
return VOID_ (scm_source_properties (expr));
|
||||
return VOID_ ();
|
||||
}
|
||||
|
||||
static SCM
|
||||
|
|
@ -583,12 +522,11 @@ expand_if (SCM expr, SCM env SCM_UNUSED)
|
|||
const SCM cdr_expr = CDR (expr);
|
||||
const long length = scm_ilength (cdr_expr);
|
||||
ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
|
||||
return CONDITIONAL (scm_source_properties (expr),
|
||||
expand (CADR (expr), env),
|
||||
return CONDITIONAL (expand (CADR (expr), env),
|
||||
expand (CADDR (expr), env),
|
||||
((length == 3)
|
||||
? expand (CADDDR (expr), env)
|
||||
: VOID_ (SCM_BOOL_F)));
|
||||
: VOID_ ()));
|
||||
}
|
||||
|
||||
/* A helper function for expand_lambda to support checking for duplicate
|
||||
|
|
@ -666,15 +604,14 @@ expand_lambda_case (SCM clause, SCM alternate, SCM env)
|
|||
if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE))
|
||||
abort ();
|
||||
|
||||
return LAMBDA_CASE (SCM_BOOL_F, req, SCM_BOOL_F, rest, SCM_BOOL_F,
|
||||
return LAMBDA_CASE (req, SCM_BOOL_F, rest, SCM_BOOL_F,
|
||||
SCM_EOL, vars, body, alternate);
|
||||
}
|
||||
|
||||
static SCM
|
||||
expand_lambda (SCM expr, SCM env)
|
||||
{
|
||||
return LAMBDA (scm_source_properties (expr),
|
||||
SCM_EOL,
|
||||
return LAMBDA (SCM_EOL,
|
||||
expand_lambda_case (CDR (expr), SCM_BOOL_F, env));
|
||||
}
|
||||
|
||||
|
|
@ -777,7 +714,7 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
|
|||
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
|
||||
env = scm_acons (x, CAR (vars), env);
|
||||
if (scm_is_symbol (x))
|
||||
inits = scm_cons (CONST_ (SCM_BOOL_F, SCM_BOOL_F), inits);
|
||||
inits = scm_cons (CONST_ (SCM_BOOL_F), inits);
|
||||
else
|
||||
{
|
||||
ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)),
|
||||
|
|
@ -845,15 +782,14 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
|
|||
inits = scm_reverse_x (inits, SCM_UNDEFINED);
|
||||
body = expand_sequence (body, env);
|
||||
|
||||
return LAMBDA_CASE (SCM_BOOL_F, req, opt, rest, kw, inits, vars, body,
|
||||
return LAMBDA_CASE (req, opt, rest, kw, inits, vars, body,
|
||||
alternate);
|
||||
}
|
||||
|
||||
static SCM
|
||||
expand_lambda_star (SCM expr, SCM env)
|
||||
{
|
||||
return LAMBDA (scm_source_properties (expr),
|
||||
SCM_EOL,
|
||||
return LAMBDA (SCM_EOL,
|
||||
expand_lambda_star_case (CDR (expr), SCM_BOOL_F, env));
|
||||
}
|
||||
|
||||
|
|
@ -875,8 +811,7 @@ expand_case_lambda (SCM expr, SCM env)
|
|||
{
|
||||
ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
|
||||
|
||||
return LAMBDA (scm_source_properties (expr),
|
||||
SCM_EOL,
|
||||
return LAMBDA (SCM_EOL,
|
||||
expand_case_lambda_clauses (CADR (expr), CDDR (expr), env));
|
||||
}
|
||||
|
||||
|
|
@ -898,8 +833,7 @@ expand_case_lambda_star (SCM expr, SCM env)
|
|||
{
|
||||
ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
|
||||
|
||||
return LAMBDA (scm_source_properties (expr),
|
||||
SCM_EOL,
|
||||
return LAMBDA (SCM_EOL,
|
||||
expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env));
|
||||
}
|
||||
|
||||
|
|
@ -973,16 +907,14 @@ expand_named_let (const SCM expr, SCM env)
|
|||
inner_env = expand_env_extend (inner_env, var_names, var_syms);
|
||||
|
||||
return LETREC
|
||||
(scm_source_properties (expr), SCM_BOOL_F,
|
||||
(SCM_BOOL_F,
|
||||
scm_list_1 (name), scm_list_1 (name_sym),
|
||||
scm_list_1 (LAMBDA (SCM_BOOL_F,
|
||||
SCM_EOL,
|
||||
LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F,
|
||||
scm_list_1 (LAMBDA (SCM_EOL,
|
||||
LAMBDA_CASE (var_names, SCM_EOL, SCM_BOOL_F,
|
||||
SCM_BOOL_F, SCM_EOL, var_syms,
|
||||
expand_sequence (CDDDR (expr), inner_env),
|
||||
SCM_BOOL_F))),
|
||||
CALL (SCM_BOOL_F,
|
||||
LEXICAL_REF (SCM_BOOL_F, name, name_sym),
|
||||
CALL (LEXICAL_REF (name, name_sym),
|
||||
expand_exprs (inits, env)));
|
||||
}
|
||||
|
||||
|
|
@ -1010,8 +942,7 @@ expand_let (SCM expr, SCM env)
|
|||
{
|
||||
SCM var_names, var_syms, inits;
|
||||
transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
|
||||
return LET (SCM_BOOL_F,
|
||||
var_names, var_syms, expand_exprs (inits, env),
|
||||
return LET (var_names, var_syms, expand_exprs (inits, env),
|
||||
expand_sequence (CDDR (expr),
|
||||
expand_env_extend (env, var_names,
|
||||
var_syms)));
|
||||
|
|
@ -1037,7 +968,7 @@ expand_letrec_helper (SCM expr, SCM env, SCM in_order_p)
|
|||
SCM var_names, var_syms, inits;
|
||||
transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
|
||||
env = expand_env_extend (env, var_names, var_syms);
|
||||
return LETREC (SCM_BOOL_F, in_order_p,
|
||||
return LETREC (in_order_p,
|
||||
var_names, var_syms, expand_exprs (inits, env),
|
||||
expand_sequence (CDDR (expr), env));
|
||||
}
|
||||
|
|
@ -1071,7 +1002,7 @@ expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
|
|||
sym = scm_gensym (SCM_UNDEFINED);
|
||||
init = CADR (bind);
|
||||
|
||||
return LET (SCM_BOOL_F, scm_list_1 (name), scm_list_1 (sym),
|
||||
return LET (scm_list_1 (name), scm_list_1 (sym),
|
||||
scm_list_1 (expand (init, env)),
|
||||
expand_letstar_clause (CDR (bindings), body,
|
||||
scm_acons (name, sym, env)));
|
||||
|
|
@ -1097,16 +1028,14 @@ expand_or (SCM expr, SCM env SCM_UNUSED)
|
|||
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
|
||||
|
||||
if (scm_is_null (CDR (expr)))
|
||||
return CONST_ (SCM_BOOL_F, SCM_BOOL_F);
|
||||
return CONST_ (SCM_BOOL_F);
|
||||
else
|
||||
{
|
||||
SCM tmp = scm_gensym (SCM_UNDEFINED);
|
||||
return LET (SCM_BOOL_F,
|
||||
scm_list_1 (tmp), scm_list_1 (tmp),
|
||||
return LET (scm_list_1 (tmp), scm_list_1 (tmp),
|
||||
scm_list_1 (expand (CADR (expr), env)),
|
||||
CONDITIONAL (SCM_BOOL_F,
|
||||
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
|
||||
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
|
||||
CONDITIONAL (LEXICAL_REF (tmp, tmp),
|
||||
LEXICAL_REF (tmp, tmp),
|
||||
expand_or (CDR (expr),
|
||||
scm_acons (tmp, tmp, env))));
|
||||
}
|
||||
|
|
@ -1121,7 +1050,7 @@ expand_quote (SCM expr, SCM env SCM_UNUSED)
|
|||
ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
|
||||
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
|
||||
quotee = CAR (cdr_expr);
|
||||
return CONST_ (scm_source_properties (expr), quotee);
|
||||
return CONST_ (quotee);
|
||||
}
|
||||
|
||||
static SCM
|
||||
|
|
@ -1139,18 +1068,15 @@ expand_set_x (SCM expr, SCM env)
|
|||
switch (SCM_EXPANDED_TYPE (vmem))
|
||||
{
|
||||
case SCM_EXPANDED_LEXICAL_REF:
|
||||
return LEXICAL_SET (scm_source_properties (expr),
|
||||
SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME),
|
||||
return LEXICAL_SET (SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME),
|
||||
SCM_EXPANDED_REF (vmem, LEXICAL_REF, GENSYM),
|
||||
expand (CADDR (expr), env));
|
||||
case SCM_EXPANDED_TOPLEVEL_REF:
|
||||
return TOPLEVEL_SET (scm_source_properties (expr),
|
||||
SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD),
|
||||
return TOPLEVEL_SET (SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD),
|
||||
SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME),
|
||||
expand (CADDR (expr), env));
|
||||
case SCM_EXPANDED_MODULE_REF:
|
||||
return MODULE_SET (scm_source_properties (expr),
|
||||
SCM_EXPANDED_REF (vmem, MODULE_REF, MOD),
|
||||
return MODULE_SET (SCM_EXPANDED_REF (vmem, MODULE_REF, MOD),
|
||||
SCM_EXPANDED_REF (vmem, MODULE_REF, NAME),
|
||||
SCM_EXPANDED_REF (vmem, MODULE_REF, PUBLIC),
|
||||
expand (CADDR (expr), env));
|
||||
|
|
@ -1282,27 +1208,25 @@ compute_assigned (SCM exp, SCM assigned)
|
|||
static SCM
|
||||
box_value (SCM exp)
|
||||
{
|
||||
return PRIMCALL (SCM_BOOL_F, scm_from_latin1_symbol ("make-variable"),
|
||||
return PRIMCALL (scm_from_latin1_symbol ("make-variable"),
|
||||
scm_list_1 (exp));
|
||||
}
|
||||
|
||||
static SCM
|
||||
box_lexical (SCM name, SCM sym)
|
||||
{
|
||||
return LEXICAL_SET (SCM_BOOL_F, name, sym,
|
||||
box_value (LEXICAL_REF (SCM_BOOL_F, name, sym)));
|
||||
return LEXICAL_SET (name, sym,
|
||||
box_value (LEXICAL_REF (name, sym)));
|
||||
}
|
||||
|
||||
static SCM
|
||||
init_if_unbound (SCM src, SCM name, SCM sym, SCM init)
|
||||
init_if_unbound (SCM name, SCM sym, SCM init)
|
||||
{
|
||||
return CONDITIONAL (src,
|
||||
PRIMCALL (src,
|
||||
scm_from_latin1_symbol ("eq?"),
|
||||
scm_list_2 (LEXICAL_REF (src, name, sym),
|
||||
return CONDITIONAL (PRIMCALL (scm_from_latin1_symbol ("eq?"),
|
||||
scm_list_2 (LEXICAL_REF (name, sym),
|
||||
const_unbound)),
|
||||
LEXICAL_SET (src, name, sym, init),
|
||||
VOID_ (src));
|
||||
LEXICAL_SET (name, sym, init),
|
||||
VOID_ ());
|
||||
}
|
||||
|
||||
static SCM
|
||||
|
|
@ -1310,11 +1234,9 @@ init_boxes (SCM names, SCM syms, SCM vals, SCM body)
|
|||
{
|
||||
if (scm_is_null (names)) return body;
|
||||
|
||||
return SEQ (SCM_BOOL_F,
|
||||
PRIMCALL
|
||||
(SCM_BOOL_F,
|
||||
scm_from_latin1_symbol ("variable-set!"),
|
||||
scm_list_2 (LEXICAL_REF (SCM_BOOL_F, CAR (names), CAR (syms)),
|
||||
return SEQ (PRIMCALL
|
||||
(scm_from_latin1_symbol ("variable-set!"),
|
||||
scm_list_2 (LEXICAL_REF (CAR (names), CAR (syms)),
|
||||
CAR (vals))),
|
||||
init_boxes (CDR (names), CDR (syms), CDR (vals), body));
|
||||
}
|
||||
|
|
@ -1347,100 +1269,87 @@ convert_assignment (SCM exp, SCM assigned)
|
|||
|
||||
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
|
||||
return PRIMCALL
|
||||
(REF (exp, LEXICAL_REF, SRC),
|
||||
scm_from_latin1_symbol ("variable-ref"),
|
||||
(scm_from_latin1_symbol ("variable-ref"),
|
||||
scm_list_1 (exp));
|
||||
return exp;
|
||||
}
|
||||
|
||||
case SCM_EXPANDED_LEXICAL_SET:
|
||||
return PRIMCALL
|
||||
(REF (exp, LEXICAL_SET, SRC),
|
||||
scm_from_latin1_symbol ("variable-set!"),
|
||||
scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, SRC),
|
||||
REF (exp, LEXICAL_SET, NAME),
|
||||
(scm_from_latin1_symbol ("variable-set!"),
|
||||
scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, NAME),
|
||||
REF (exp, LEXICAL_SET, GENSYM)),
|
||||
convert_assignment (REF (exp, LEXICAL_SET, EXP),
|
||||
assigned)));
|
||||
|
||||
case SCM_EXPANDED_MODULE_SET:
|
||||
return MODULE_SET
|
||||
(REF (exp, MODULE_SET, SRC),
|
||||
REF (exp, MODULE_SET, MOD),
|
||||
(REF (exp, MODULE_SET, MOD),
|
||||
REF (exp, MODULE_SET, NAME),
|
||||
REF (exp, MODULE_SET, PUBLIC),
|
||||
convert_assignment (REF (exp, MODULE_SET, EXP), assigned));
|
||||
|
||||
case SCM_EXPANDED_TOPLEVEL_SET:
|
||||
return TOPLEVEL_SET
|
||||
(REF (exp, TOPLEVEL_SET, SRC),
|
||||
REF (exp, TOPLEVEL_SET, MOD),
|
||||
(REF (exp, TOPLEVEL_SET, MOD),
|
||||
REF (exp, TOPLEVEL_SET, NAME),
|
||||
convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned));
|
||||
|
||||
case SCM_EXPANDED_TOPLEVEL_DEFINE:
|
||||
return TOPLEVEL_DEFINE
|
||||
(REF (exp, TOPLEVEL_DEFINE, SRC),
|
||||
REF (exp, TOPLEVEL_DEFINE, MOD),
|
||||
(REF (exp, TOPLEVEL_DEFINE, MOD),
|
||||
REF (exp, TOPLEVEL_DEFINE, NAME),
|
||||
convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP),
|
||||
assigned));
|
||||
|
||||
case SCM_EXPANDED_CONDITIONAL:
|
||||
return CONDITIONAL
|
||||
(REF (exp, CONDITIONAL, SRC),
|
||||
convert_assignment (REF (exp, CONDITIONAL, TEST), assigned),
|
||||
(convert_assignment (REF (exp, CONDITIONAL, TEST), assigned),
|
||||
convert_assignment (REF (exp, CONDITIONAL, CONSEQUENT), assigned),
|
||||
convert_assignment (REF (exp, CONDITIONAL, ALTERNATE), assigned));
|
||||
|
||||
case SCM_EXPANDED_CALL:
|
||||
return CALL
|
||||
(REF (exp, CALL, SRC),
|
||||
convert_assignment (REF (exp, CALL, PROC), assigned),
|
||||
(convert_assignment (REF (exp, CALL, PROC), assigned),
|
||||
convert_assignment (REF (exp, CALL, ARGS), assigned));
|
||||
|
||||
case SCM_EXPANDED_PRIMCALL:
|
||||
return PRIMCALL
|
||||
(REF (exp, PRIMCALL, SRC),
|
||||
REF (exp, PRIMCALL, NAME),
|
||||
(REF (exp, PRIMCALL, NAME),
|
||||
convert_assignment (REF (exp, PRIMCALL, ARGS), assigned));
|
||||
|
||||
case SCM_EXPANDED_SEQ:
|
||||
return SEQ
|
||||
(REF (exp, SEQ, SRC),
|
||||
convert_assignment (REF (exp, SEQ, HEAD), assigned),
|
||||
(convert_assignment (REF (exp, SEQ, HEAD), assigned),
|
||||
convert_assignment (REF (exp, SEQ, TAIL), assigned));
|
||||
|
||||
case SCM_EXPANDED_LAMBDA:
|
||||
return LAMBDA
|
||||
(REF (exp, LAMBDA, SRC),
|
||||
REF (exp, LAMBDA, META),
|
||||
(REF (exp, LAMBDA, META),
|
||||
scm_is_false (REF (exp, LAMBDA, BODY))
|
||||
/* Give a body to case-lambda with no clauses. */
|
||||
? LAMBDA_CASE (SCM_BOOL_F, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F,
|
||||
? LAMBDA_CASE (SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F,
|
||||
SCM_EOL, SCM_EOL,
|
||||
PRIMCALL
|
||||
(SCM_BOOL_F,
|
||||
scm_from_latin1_symbol ("throw"),
|
||||
scm_list_5 (CONST_ (SCM_BOOL_F, scm_args_number_key),
|
||||
CONST_ (SCM_BOOL_F, SCM_BOOL_F),
|
||||
CONST_ (SCM_BOOL_F, scm_from_latin1_string
|
||||
(scm_from_latin1_symbol ("throw"),
|
||||
scm_list_5 (CONST_ (scm_args_number_key),
|
||||
CONST_ (SCM_BOOL_F),
|
||||
CONST_ (scm_from_latin1_string
|
||||
("Wrong number of arguments")),
|
||||
CONST_ (SCM_BOOL_F, SCM_EOL),
|
||||
CONST_ (SCM_BOOL_F, SCM_BOOL_F))),
|
||||
CONST_ (SCM_EOL),
|
||||
CONST_ (SCM_BOOL_F))),
|
||||
SCM_BOOL_F)
|
||||
: convert_assignment (REF (exp, LAMBDA, BODY), assigned));
|
||||
|
||||
case SCM_EXPANDED_LAMBDA_CASE:
|
||||
{
|
||||
SCM src, req, opt, rest, kw, inits, syms, body, alt;
|
||||
SCM req, opt, rest, kw, inits, syms, body, alt;
|
||||
SCM namewalk, symwalk, new_inits, seq;
|
||||
|
||||
/* Box assigned formals. Since initializers can capture
|
||||
previous formals, we convert initializers to be in the body
|
||||
instead of in the "header". */
|
||||
|
||||
src = REF (exp, LAMBDA_CASE, SRC);
|
||||
req = REF (exp, LAMBDA_CASE, REQ);
|
||||
opt = REF (exp, LAMBDA_CASE, OPT);
|
||||
rest = REF (exp, LAMBDA_CASE, REST);
|
||||
|
|
@ -1470,7 +1379,7 @@ convert_assignment (SCM exp, SCM assigned)
|
|||
inits = CDR (inits))
|
||||
{
|
||||
SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (inits);
|
||||
seq = scm_cons (init_if_unbound (src, name, sym, init), seq);
|
||||
seq = scm_cons (init_if_unbound (name, sym, init), seq);
|
||||
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
|
||||
seq = scm_cons (box_lexical (name, sym), seq);
|
||||
}
|
||||
|
|
@ -1489,23 +1398,22 @@ convert_assignment (SCM exp, SCM assigned)
|
|||
symwalk = CDR (symwalk), inits = CDR (inits))
|
||||
{
|
||||
SCM sym = CAR (symwalk), init = CAR (inits);
|
||||
seq = scm_cons (init_if_unbound (src, SCM_BOOL_F, sym, init), seq);
|
||||
seq = scm_cons (init_if_unbound (SCM_BOOL_F, sym, init), seq);
|
||||
if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
|
||||
seq = scm_cons (box_lexical (SCM_BOOL_F, sym), seq);
|
||||
}
|
||||
|
||||
for (; scm_is_pair (seq); seq = CDR (seq))
|
||||
body = SEQ (src, CAR (seq), body);
|
||||
body = SEQ (CAR (seq), body);
|
||||
|
||||
return LAMBDA_CASE
|
||||
(src, req, opt, rest, kw, new_inits, syms, body, alt);
|
||||
(req, opt, rest, kw, new_inits, syms, body, alt);
|
||||
}
|
||||
|
||||
case SCM_EXPANDED_LET:
|
||||
{
|
||||
SCM src, names, syms, vals, body, new_vals, walk;
|
||||
SCM names, syms, vals, body, new_vals, walk;
|
||||
|
||||
src = REF (exp, LET, SRC);
|
||||
names = REF (exp, LET, NAMES);
|
||||
syms = REF (exp, LET, GENSYMS);
|
||||
vals = convert_assignment (REF (exp, LET, VALS), assigned);
|
||||
|
|
@ -1523,28 +1431,26 @@ convert_assignment (SCM exp, SCM assigned)
|
|||
}
|
||||
new_vals = scm_reverse (new_vals);
|
||||
|
||||
return LET (src, names, syms, new_vals, body);
|
||||
return LET (names, syms, new_vals, body);
|
||||
}
|
||||
|
||||
case SCM_EXPANDED_LETREC:
|
||||
{
|
||||
SCM src, names, syms, vals, empty_box, boxes, body;
|
||||
SCM names, syms, vals, empty_box, boxes, body;
|
||||
|
||||
src = REF (exp, LETREC, SRC);
|
||||
names = REF (exp, LETREC, NAMES);
|
||||
syms = REF (exp, LETREC, GENSYMS);
|
||||
vals = convert_assignment (REF (exp, LETREC, VALS), assigned);
|
||||
body = convert_assignment (REF (exp, LETREC, BODY), assigned);
|
||||
|
||||
empty_box =
|
||||
PRIMCALL (SCM_BOOL_F,
|
||||
scm_from_latin1_symbol ("make-undefined-variable"),
|
||||
PRIMCALL (scm_from_latin1_symbol ("make-undefined-variable"),
|
||||
SCM_EOL);
|
||||
boxes = scm_make_list (scm_length (names), empty_box);
|
||||
|
||||
if (scm_is_true (REF (exp, LETREC, IN_ORDER_P)))
|
||||
return LET
|
||||
(src, names, syms, boxes,
|
||||
(names, syms, boxes,
|
||||
init_boxes (names, syms, vals, body));
|
||||
else
|
||||
{
|
||||
|
|
@ -1554,17 +1460,16 @@ convert_assignment (SCM exp, SCM assigned)
|
|||
{
|
||||
SCM tmp = scm_gensym (SCM_UNDEFINED);
|
||||
tmps = scm_cons (tmp, tmps);
|
||||
inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, SCM_BOOL_F, tmp),
|
||||
inits = scm_cons (LEXICAL_REF (SCM_BOOL_F, tmp),
|
||||
inits);
|
||||
}
|
||||
tmps = scm_reverse (tmps);
|
||||
inits = scm_reverse (inits);
|
||||
|
||||
return LET
|
||||
(src, names, syms, boxes,
|
||||
SEQ (src,
|
||||
LET (src, names, tmps, vals,
|
||||
init_boxes (names, syms, inits, VOID_ (src))),
|
||||
(names, syms, boxes,
|
||||
SEQ (LET (names, tmps, vals,
|
||||
init_boxes (names, syms, inits, VOID_ ())),
|
||||
body));
|
||||
}
|
||||
}
|
||||
|
|
@ -1654,7 +1559,7 @@ scm_init_expand ()
|
|||
exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list);
|
||||
|
||||
const_unbound =
|
||||
CONST_ (SCM_BOOL_F, scm_list_1 (scm_from_latin1_symbol ("unbound")));
|
||||
CONST_ (scm_list_1 (scm_from_latin1_symbol ("unbound")));
|
||||
|
||||
scm_c_define_gsubr ("convert-assignment", 1, 0, 0, scm_convert_assignment);
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue