mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-03 18:50:19 +02:00
Code Activity

Boot expander no longer tracks source positions

Browse source 
* 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 2025-05-12 14:06:06 +02:00
parent 9ab8f3d807
commit 71d112cdde
1 changed files with 130 additions and 225 deletions
Download patch file Download diff file Expand all files Collapse all files

355
libguile/expand.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-2014,2016,2018-2020 /* Copyright 1995-2014,2016,2018-2020,2025
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -37,7 +37,6 @@
#include "pairs.h" #include "pairs.h"
#include "ports.h" #include "ports.h"
#include "print.h" #include "print.h"
#include "srcprop.h"
#include "strings.h" #include "strings.h"
#include "symbols.h" #include "symbols.h"
#include "throw.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 /* The trailing underscores on these first to are to avoid spurious
conflicts with macros defined on MinGW. */ conflicts with macros defined on MinGW. */
#define VOID_(src) \ #define VOID_() \
SCM_MAKE_EXPANDED_VOID(src) SCM_MAKE_EXPANDED_VOID(SCM_BOOL_F)
#define CONST_(src, exp) \ #define CONST_(exp) \
SCM_MAKE_EXPANDED_CONST(src, exp) SCM_MAKE_EXPANDED_CONST(SCM_BOOL_F, exp)
#define PRIMITIVE_REF(src, name) \ #define PRIMITIVE_REF(name) \
SCM_MAKE_EXPANDED_PRIMITIVE_REF(src, name) SCM_MAKE_EXPANDED_PRIMITIVE_REF(SCM_BOOL_F, name)
#define LEXICAL_REF(src, name, gensym) \ #define LEXICAL_REF(name, gensym) \
SCM_MAKE_EXPANDED_LEXICAL_REF(src, name, gensym) SCM_MAKE_EXPANDED_LEXICAL_REF(SCM_BOOL_F, name, gensym)
#define LEXICAL_SET(src, name, gensym, exp) \ #define LEXICAL_SET(name, gensym, exp) \
SCM_MAKE_EXPANDED_LEXICAL_SET(src, name, gensym, exp) SCM_MAKE_EXPANDED_LEXICAL_SET(SCM_BOOL_F, name, gensym, exp)
#define MODULE_REF(src, mod, name, public) \ #define MODULE_REF(mod, name, public) \
SCM_MAKE_EXPANDED_MODULE_REF(src, mod, name, public) SCM_MAKE_EXPANDED_MODULE_REF(SCM_BOOL_F, mod, name, public)
#define MODULE_SET(src, mod, name, public, exp) \ #define MODULE_SET(mod, name, public, exp) \
SCM_MAKE_EXPANDED_MODULE_SET(src, mod, name, public, exp) SCM_MAKE_EXPANDED_MODULE_SET(SCM_BOOL_F, mod, name, public, exp)
#define TOPLEVEL_REF(src, mod, name) \ #define TOPLEVEL_REF(mod, name) \
SCM_MAKE_EXPANDED_TOPLEVEL_REF(src, mod, name) SCM_MAKE_EXPANDED_TOPLEVEL_REF(SCM_BOOL_F, mod, name)
#define TOPLEVEL_SET(src, mod, name, exp) \ #define TOPLEVEL_SET(mod, name, exp) \
SCM_MAKE_EXPANDED_TOPLEVEL_SET(src, mod, name, exp) SCM_MAKE_EXPANDED_TOPLEVEL_SET(SCM_BOOL_F, mod, name, exp)
#define TOPLEVEL_DEFINE(src, mod, name, exp) \ #define TOPLEVEL_DEFINE(mod, name, exp) \
SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(src, mod, name, exp) SCM_MAKE_EXPANDED_TOPLEVEL_DEFINE(SCM_BOOL_F, mod, name, exp)
#define CONDITIONAL(src, test, consequent, alternate) \ #define CONDITIONAL(test, consequent, alternate) \
SCM_MAKE_EXPANDED_CONDITIONAL(src, test, consequent, alternate) SCM_MAKE_EXPANDED_CONDITIONAL(SCM_BOOL_F, test, consequent, alternate)
#define PRIMCALL(src, name, exps) \ #define PRIMCALL(name, exps) \
SCM_MAKE_EXPANDED_PRIMCALL(src, name, exps) SCM_MAKE_EXPANDED_PRIMCALL(SCM_BOOL_F, name, exps)
#define CALL(src, proc, exps) \ #define CALL(proc, exps) \
SCM_MAKE_EXPANDED_CALL(src, proc, exps) SCM_MAKE_EXPANDED_CALL(SCM_BOOL_F, proc, exps)
#define SEQ(src, head, tail) \ #define SEQ(head, tail) \
SCM_MAKE_EXPANDED_SEQ(src, head, tail) SCM_MAKE_EXPANDED_SEQ(SCM_BOOL_F, head, tail)
#define LAMBDA(src, meta, body) \ #define LAMBDA(meta, body) \
SCM_MAKE_EXPANDED_LAMBDA(src, meta, body) SCM_MAKE_EXPANDED_LAMBDA(SCM_BOOL_F, meta, body)
#define LAMBDA_CASE(src, req, opt, rest, kw, inits, gensyms, body, alternate) \ #define LAMBDA_CASE(req, opt, rest, kw, inits, gensyms, body, alternate) \
SCM_MAKE_EXPANDED_LAMBDA_CASE(src, 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(src, names, gensyms, vals, body) \ #define LET(names, gensyms, vals, body) \
SCM_MAKE_EXPANDED_LET(src, names, gensyms, vals, body) SCM_MAKE_EXPANDED_LET(SCM_BOOL_F, names, gensyms, vals, body)
#define LETREC(src, in_order_p, names, gensyms, vals, body) \ #define LETREC(in_order_p, names, gensyms, vals, body) \
SCM_MAKE_EXPANDED_LETREC(src, 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 CAR(x) SCM_CAR(x)
#define CDR(x) SCM_CDR(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 static void
syntax_error (const char* const msg, const SCM form, const SCM expr) syntax_error (const char* const msg, const SCM form, const SCM expr)
{ {
SCM msg_string = scm_from_utf8_string (msg); SCM msg_string = scm_from_utf8_string (msg);
SCM filename = SCM_BOOL_F;
SCM linenr = SCM_BOOL_F;
const char *format; const char *format;
SCM args; 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_UNBNDP (expr))
{ {
if (scm_is_true (filename)) format = "~A ~S in expression ~S.";
{ args = scm_list_3 (msg_string, form, expr);
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 else
{ {
if (scm_is_true (filename)) format = "~A ~S.";
{ args = scm_list_2 (msg_string, form);
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); 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); syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF) if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_PRIMITIVE_REF)
return PRIMCALL (scm_source_properties (exp), return PRIMCALL (SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
SCM_EXPANDED_REF (proc, PRIMITIVE_REF, NAME),
args); args);
else else
return CALL (scm_source_properties (exp), proc, args); return CALL (proc, args);
} }
} }
else if (scm_is_symbol (exp)) else if (scm_is_symbol (exp))
{ {
SCM gensym = expand_env_lexical_gensym (env, exp); SCM gensym = expand_env_lexical_gensym (env, exp);
if (scm_is_true (gensym)) if (scm_is_true (gensym))
return LEXICAL_REF (SCM_BOOL_F, exp, gensym); return LEXICAL_REF (exp, gensym);
else else
return TOPLEVEL_REF (SCM_BOOL_F, SCM_BOOL_F, exp); return TOPLEVEL_REF (SCM_BOOL_F, exp);
} }
else else
return CONST_ (SCM_BOOL_F, exp); return CONST_ (exp);
} }
static SCM static SCM
@ -402,8 +351,7 @@ expand_sequence (const SCM forms, const SCM env)
if (scm_is_null (CDR (forms))) if (scm_is_null (CDR (forms)))
return expand (CAR (forms), env); return expand (CAR (forms), env);
else else
return SEQ (scm_source_properties (forms), return SEQ (expand (CAR (forms), env),
expand (CAR (forms), env),
expand_sequence (CDR (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_ilength (CADR (expr)) > 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr); ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
return MODULE_REF (scm_source_properties (expr), return MODULE_REF (CADR (expr), CADDR (expr), SCM_BOOL_T);
CADR (expr), CADDR (expr), SCM_BOOL_T);
} }
static SCM 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); ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
if (scm_is_eq (CADR (expr), sym_primitive)) 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); ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
return MODULE_REF (scm_source_properties (expr), return MODULE_REF (CADR (expr), CADDR (expr), SCM_BOOL_F);
CADR (expr), CADDR (expr), SCM_BOOL_F);
} }
static SCM static SCM
@ -442,17 +388,16 @@ expand_and (SCM expr, SCM env)
const SCM cdr_expr = CDR (expr); const SCM cdr_expr = CDR (expr);
if (scm_is_null (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); ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
if (scm_is_null (CDR (cdr_expr))) if (scm_is_null (CDR (cdr_expr)))
return expand (CAR (cdr_expr), env); return expand (CAR (cdr_expr), env);
else else
return CONDITIONAL (scm_source_properties (expr), return CONDITIONAL (expand (CAR (cdr_expr), env),
expand (CAR (cdr_expr), env),
expand_and (cdr_expr, env), expand_and (cdr_expr, env),
CONST_ (SCM_BOOL_F, SCM_BOOL_F)); CONST_ (SCM_BOOL_F));
} }
static SCM static SCM
@ -480,7 +425,7 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
} }
if (scm_is_null (rest)) if (scm_is_null (rest))
rest = VOID_ (SCM_BOOL_F); rest = VOID_ ();
else else
rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env); 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); SCM new_env = scm_acons (tmp, tmp, env);
ASSERT_SYNTAX (length > 2, s_missing_recipient, clause); ASSERT_SYNTAX (length > 2, s_missing_recipient, clause);
ASSERT_SYNTAX (length == 3, s_extra_expression, clause); ASSERT_SYNTAX (length == 3, s_extra_expression, clause);
return LET (SCM_BOOL_F, return LET (scm_list_1 (tmp),
scm_list_1 (tmp),
scm_list_1 (tmp), scm_list_1 (tmp),
scm_list_1 (expand (test, env)), scm_list_1 (expand (test, env)),
CONDITIONAL (SCM_BOOL_F, CONDITIONAL (LEXICAL_REF (tmp, tmp),
LEXICAL_REF (SCM_BOOL_F, tmp, tmp), CALL (expand (CADDR (clause), new_env),
CALL (SCM_BOOL_F, scm_list_1 (LEXICAL_REF (tmp, tmp))),
expand (CADDR (clause), new_env),
scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
tmp, tmp))),
rest)); rest));
} }
/* FIXME length == 1 case */ /* FIXME length == 1 case */
else else
return CONDITIONAL (SCM_BOOL_F, return CONDITIONAL (expand (test, env),
expand (test, env),
expand_sequence (CDR (clause), env), expand_sequence (CDR (clause), env),
rest); rest);
} }
@ -552,15 +492,14 @@ expand_define (SCM expr, SCM env)
{ {
ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr); ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
return TOPLEVEL_DEFINE return TOPLEVEL_DEFINE
(scm_source_properties (expr), (SCM_BOOL_F,
SCM_BOOL_F,
CAR (variable), CAR (variable),
expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)), expand_lambda (scm_cons (scm_sym_lambda, scm_cons (CDR (variable), body)),
env)); env));
} }
ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr); ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, 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)); expand (CAR (body), env));
} }
@ -574,7 +513,7 @@ expand_eval_when (SCM expr, SCM env)
|| scm_is_true (scm_memq (sym_load, CADR (expr)))) || scm_is_true (scm_memq (sym_load, CADR (expr))))
return expand_sequence (CDDR (expr), env); return expand_sequence (CDDR (expr), env);
else else
return VOID_ (scm_source_properties (expr)); return VOID_ ();
} }
static SCM static SCM
@ -583,12 +522,11 @@ expand_if (SCM expr, SCM env SCM_UNUSED)
const SCM cdr_expr = CDR (expr); const SCM cdr_expr = CDR (expr);
const long length = scm_ilength (cdr_expr); const long length = scm_ilength (cdr_expr);
ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr); ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
return CONDITIONAL (scm_source_properties (expr), return CONDITIONAL (expand (CADR (expr), env),
expand (CADR (expr), env),
expand (CADDR (expr), env), expand (CADDR (expr), env),
((length == 3) ((length == 3)
? expand (CADDDR (expr), env) ? expand (CADDDR (expr), env)
: VOID_ (SCM_BOOL_F))); : VOID_ ()));
} }
/* A helper function for expand_lambda to support checking for duplicate /* 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)) if (scm_is_true (alternate) && !(SCM_EXPANDED_P (alternate) && SCM_EXPANDED_TYPE (alternate) == SCM_EXPANDED_LAMBDA_CASE))
abort (); 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); SCM_EOL, vars, body, alternate);
} }
static SCM static SCM
expand_lambda (SCM expr, SCM env) expand_lambda (SCM expr, SCM env)
{ {
return LAMBDA (scm_source_properties (expr), return LAMBDA (SCM_EOL,
SCM_EOL,
expand_lambda_case (CDR (expr), SCM_BOOL_F, env)); 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); vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
env = scm_acons (x, CAR (vars), env); env = scm_acons (x, CAR (vars), env);
if (scm_is_symbol (x)) 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 else
{ {
ASSERT_SYNTAX (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)), 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); inits = scm_reverse_x (inits, SCM_UNDEFINED);
body = expand_sequence (body, env); 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); alternate);
} }
static SCM static SCM
expand_lambda_star (SCM expr, SCM env) expand_lambda_star (SCM expr, SCM env)
{ {
return LAMBDA (scm_source_properties (expr), return LAMBDA (SCM_EOL,
SCM_EOL,
expand_lambda_star_case (CDR (expr), SCM_BOOL_F, env)); 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); ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
return LAMBDA (scm_source_properties (expr), return LAMBDA (SCM_EOL,
SCM_EOL,
expand_case_lambda_clauses (CADR (expr), CDDR (expr), env)); 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); ASSERT_SYNTAX (scm_is_pair (CDR (expr)), s_missing_expression, expr);
return LAMBDA (scm_source_properties (expr), return LAMBDA (SCM_EOL,
SCM_EOL,
expand_case_lambda_star_clauses (CADR (expr), CDDR (expr), env)); 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); inner_env = expand_env_extend (inner_env, var_names, var_syms);
return LETREC return LETREC
(scm_source_properties (expr), SCM_BOOL_F, (SCM_BOOL_F,
scm_list_1 (name), scm_list_1 (name_sym), scm_list_1 (name), scm_list_1 (name_sym),
scm_list_1 (LAMBDA (SCM_BOOL_F, scm_list_1 (LAMBDA (SCM_EOL,
SCM_EOL, LAMBDA_CASE (var_names, SCM_EOL, SCM_BOOL_F,
LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F,
SCM_BOOL_F, SCM_EOL, var_syms, SCM_BOOL_F, SCM_EOL, var_syms,
expand_sequence (CDDDR (expr), inner_env), expand_sequence (CDDDR (expr), inner_env),
SCM_BOOL_F))), SCM_BOOL_F))),
CALL (SCM_BOOL_F, CALL (LEXICAL_REF (name, name_sym),
LEXICAL_REF (SCM_BOOL_F, name, name_sym),
expand_exprs (inits, env))); expand_exprs (inits, env)));
} }
@ -1010,8 +942,7 @@ expand_let (SCM expr, SCM env)
{ {
SCM var_names, var_syms, inits; SCM var_names, var_syms, inits;
transform_bindings (bindings, expr, &var_names, &var_syms, &inits); transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
return LET (SCM_BOOL_F, return LET (var_names, var_syms, expand_exprs (inits, env),
var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr), expand_sequence (CDDR (expr),
expand_env_extend (env, var_names, expand_env_extend (env, var_names,
var_syms))); var_syms)));
@ -1037,7 +968,7 @@ expand_letrec_helper (SCM expr, SCM env, SCM in_order_p)
SCM var_names, var_syms, inits; SCM var_names, var_syms, inits;
transform_bindings (bindings, expr, &var_names, &var_syms, &inits); transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
env = expand_env_extend (env, var_names, var_syms); 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), var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr), 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); sym = scm_gensym (SCM_UNDEFINED);
init = CADR (bind); 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)), scm_list_1 (expand (init, env)),
expand_letstar_clause (CDR (bindings), body, expand_letstar_clause (CDR (bindings), body,
scm_acons (name, sym, env))); 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); ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
if (scm_is_null (CDR (expr))) if (scm_is_null (CDR (expr)))
return CONST_ (SCM_BOOL_F, SCM_BOOL_F); return CONST_ (SCM_BOOL_F);
else else
{ {
SCM tmp = scm_gensym (SCM_UNDEFINED); SCM tmp = scm_gensym (SCM_UNDEFINED);
return LET (SCM_BOOL_F, return LET (scm_list_1 (tmp), scm_list_1 (tmp),
scm_list_1 (tmp), scm_list_1 (tmp),
scm_list_1 (expand (CADR (expr), env)), scm_list_1 (expand (CADR (expr), env)),
CONDITIONAL (SCM_BOOL_F, CONDITIONAL (LEXICAL_REF (tmp, tmp),
LEXICAL_REF (SCM_BOOL_F, tmp, tmp), LEXICAL_REF (tmp, tmp),
LEXICAL_REF (SCM_BOOL_F, tmp, tmp),
expand_or (CDR (expr), expand_or (CDR (expr),
scm_acons (tmp, tmp, env)))); 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) >= 0, s_bad_expression, expr);
ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr); ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
quotee = CAR (cdr_expr); quotee = CAR (cdr_expr);
return CONST_ (scm_source_properties (expr), quotee); return CONST_ (quotee);
} }
static SCM static SCM
@ -1139,18 +1068,15 @@ expand_set_x (SCM expr, SCM env)
switch (SCM_EXPANDED_TYPE (vmem)) switch (SCM_EXPANDED_TYPE (vmem))
{ {
case SCM_EXPANDED_LEXICAL_REF: case SCM_EXPANDED_LEXICAL_REF:
return LEXICAL_SET (scm_source_properties (expr), return LEXICAL_SET (SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME),
SCM_EXPANDED_REF (vmem, LEXICAL_REF, NAME),
SCM_EXPANDED_REF (vmem, LEXICAL_REF, GENSYM), SCM_EXPANDED_REF (vmem, LEXICAL_REF, GENSYM),
expand (CADDR (expr), env)); expand (CADDR (expr), env));
case SCM_EXPANDED_TOPLEVEL_REF: case SCM_EXPANDED_TOPLEVEL_REF:
return TOPLEVEL_SET (scm_source_properties (expr), return TOPLEVEL_SET (SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD),
SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, MOD),
SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME), SCM_EXPANDED_REF (vmem, TOPLEVEL_REF, NAME),
expand (CADDR (expr), env)); expand (CADDR (expr), env));
case SCM_EXPANDED_MODULE_REF: case SCM_EXPANDED_MODULE_REF:
return MODULE_SET (scm_source_properties (expr), return MODULE_SET (SCM_EXPANDED_REF (vmem, MODULE_REF, MOD),
SCM_EXPANDED_REF (vmem, MODULE_REF, MOD),
SCM_EXPANDED_REF (vmem, MODULE_REF, NAME), SCM_EXPANDED_REF (vmem, MODULE_REF, NAME),
SCM_EXPANDED_REF (vmem, MODULE_REF, PUBLIC), SCM_EXPANDED_REF (vmem, MODULE_REF, PUBLIC),
expand (CADDR (expr), env)); expand (CADDR (expr), env));
@ -1282,27 +1208,25 @@ compute_assigned (SCM exp, SCM assigned)
static SCM static SCM
box_value (SCM exp) 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)); scm_list_1 (exp));
} }
static SCM static SCM
box_lexical (SCM name, SCM sym) box_lexical (SCM name, SCM sym)
{ {
return LEXICAL_SET (SCM_BOOL_F, name, sym, return LEXICAL_SET (name, sym,
box_value (LEXICAL_REF (SCM_BOOL_F, name, sym))); box_value (LEXICAL_REF (name, sym)));
} }
static SCM 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, return CONDITIONAL (PRIMCALL (scm_from_latin1_symbol ("eq?"),
PRIMCALL (src, scm_list_2 (LEXICAL_REF (name, sym),
scm_from_latin1_symbol ("eq?"),
scm_list_2 (LEXICAL_REF (src, name, sym),
const_unbound)), const_unbound)),
LEXICAL_SET (src, name, sym, init), LEXICAL_SET (name, sym, init),
VOID_ (src)); VOID_ ());
} }
static SCM static SCM
@ -1310,11 +1234,9 @@ init_boxes (SCM names, SCM syms, SCM vals, SCM body)
{ {
if (scm_is_null (names)) return body; if (scm_is_null (names)) return body;
return SEQ (SCM_BOOL_F, return SEQ (PRIMCALL
PRIMCALL (scm_from_latin1_symbol ("variable-set!"),
(SCM_BOOL_F, scm_list_2 (LEXICAL_REF (CAR (names), CAR (syms)),
scm_from_latin1_symbol ("variable-set!"),
scm_list_2 (LEXICAL_REF (SCM_BOOL_F, CAR (names), CAR (syms)),
CAR (vals))), CAR (vals))),
init_boxes (CDR (names), CDR (syms), CDR (vals), body)); 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))) if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
return PRIMCALL return PRIMCALL
(REF (exp, LEXICAL_REF, SRC), (scm_from_latin1_symbol ("variable-ref"),
scm_from_latin1_symbol ("variable-ref"),
scm_list_1 (exp)); scm_list_1 (exp));
return exp; return exp;
} }
case SCM_EXPANDED_LEXICAL_SET: case SCM_EXPANDED_LEXICAL_SET:
return PRIMCALL return PRIMCALL
(REF (exp, LEXICAL_SET, SRC), (scm_from_latin1_symbol ("variable-set!"),
scm_from_latin1_symbol ("variable-set!"), scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, NAME),
scm_list_2 (LEXICAL_REF (REF (exp, LEXICAL_SET, SRC),
REF (exp, LEXICAL_SET, NAME),
REF (exp, LEXICAL_SET, GENSYM)), REF (exp, LEXICAL_SET, GENSYM)),
convert_assignment (REF (exp, LEXICAL_SET, EXP), convert_assignment (REF (exp, LEXICAL_SET, EXP),
assigned))); assigned)));
case SCM_EXPANDED_MODULE_SET: case SCM_EXPANDED_MODULE_SET:
return 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, NAME),
REF (exp, MODULE_SET, PUBLIC), REF (exp, MODULE_SET, PUBLIC),
convert_assignment (REF (exp, MODULE_SET, EXP), assigned)); convert_assignment (REF (exp, MODULE_SET, EXP), assigned));
case SCM_EXPANDED_TOPLEVEL_SET: case SCM_EXPANDED_TOPLEVEL_SET:
return 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), REF (exp, TOPLEVEL_SET, NAME),
convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned)); convert_assignment (REF (exp, TOPLEVEL_SET, EXP), assigned));
case SCM_EXPANDED_TOPLEVEL_DEFINE: case SCM_EXPANDED_TOPLEVEL_DEFINE:
return 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), REF (exp, TOPLEVEL_DEFINE, NAME),
convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP), convert_assignment (REF (exp, TOPLEVEL_DEFINE, EXP),
assigned)); assigned));
case SCM_EXPANDED_CONDITIONAL: case SCM_EXPANDED_CONDITIONAL:
return 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, CONSEQUENT), assigned),
convert_assignment (REF (exp, CONDITIONAL, ALTERNATE), assigned)); convert_assignment (REF (exp, CONDITIONAL, ALTERNATE), assigned));
case SCM_EXPANDED_CALL: case SCM_EXPANDED_CALL:
return 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)); convert_assignment (REF (exp, CALL, ARGS), assigned));
case SCM_EXPANDED_PRIMCALL: case SCM_EXPANDED_PRIMCALL:
return PRIMCALL return PRIMCALL
(REF (exp, PRIMCALL, SRC), (REF (exp, PRIMCALL, NAME),
REF (exp, PRIMCALL, NAME),
convert_assignment (REF (exp, PRIMCALL, ARGS), assigned)); convert_assignment (REF (exp, PRIMCALL, ARGS), assigned));
case SCM_EXPANDED_SEQ: case SCM_EXPANDED_SEQ:
return 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)); convert_assignment (REF (exp, SEQ, TAIL), assigned));
case SCM_EXPANDED_LAMBDA: case SCM_EXPANDED_LAMBDA:
return LAMBDA return LAMBDA
(REF (exp, LAMBDA, SRC), (REF (exp, LAMBDA, META),
REF (exp, LAMBDA, META),
scm_is_false (REF (exp, LAMBDA, BODY)) scm_is_false (REF (exp, LAMBDA, BODY))
/* Give a body to case-lambda with no clauses. */ /* 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, SCM_EOL, SCM_EOL,
PRIMCALL PRIMCALL
(SCM_BOOL_F, (scm_from_latin1_symbol ("throw"),
scm_from_latin1_symbol ("throw"), scm_list_5 (CONST_ (scm_args_number_key),
scm_list_5 (CONST_ (SCM_BOOL_F, scm_args_number_key), CONST_ (SCM_BOOL_F),
CONST_ (SCM_BOOL_F, SCM_BOOL_F), CONST_ (scm_from_latin1_string
CONST_ (SCM_BOOL_F, scm_from_latin1_string
("Wrong number of arguments")), ("Wrong number of arguments")),
CONST_ (SCM_BOOL_F, SCM_EOL), CONST_ (SCM_EOL),
CONST_ (SCM_BOOL_F, SCM_BOOL_F))), CONST_ (SCM_BOOL_F))),
SCM_BOOL_F) SCM_BOOL_F)
: convert_assignment (REF (exp, LAMBDA, BODY), assigned)); : convert_assignment (REF (exp, LAMBDA, BODY), assigned));
case SCM_EXPANDED_LAMBDA_CASE: 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; SCM namewalk, symwalk, new_inits, seq;
/* Box assigned formals. Since initializers can capture /* Box assigned formals. Since initializers can capture
previous formals, we convert initializers to be in the body previous formals, we convert initializers to be in the body
instead of in the "header". */ instead of in the "header". */
src = REF (exp, LAMBDA_CASE, SRC);
req = REF (exp, LAMBDA_CASE, REQ); req = REF (exp, LAMBDA_CASE, REQ);
opt = REF (exp, LAMBDA_CASE, OPT); opt = REF (exp, LAMBDA_CASE, OPT);
rest = REF (exp, LAMBDA_CASE, REST); rest = REF (exp, LAMBDA_CASE, REST);
@ -1470,7 +1379,7 @@ convert_assignment (SCM exp, SCM assigned)
inits = CDR (inits)) inits = CDR (inits))
{ {
SCM name = CAR (namewalk), sym = CAR (symwalk), init = CAR (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))) if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
seq = scm_cons (box_lexical (name, sym), seq); seq = scm_cons (box_lexical (name, sym), seq);
} }
@ -1489,23 +1398,22 @@ convert_assignment (SCM exp, SCM assigned)
symwalk = CDR (symwalk), inits = CDR (inits)) symwalk = CDR (symwalk), inits = CDR (inits))
{ {
SCM sym = CAR (symwalk), init = CAR (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))) if (scm_is_true (scm_hashq_ref (assigned, sym, SCM_BOOL_F)))
seq = scm_cons (box_lexical (SCM_BOOL_F, sym), seq); seq = scm_cons (box_lexical (SCM_BOOL_F, sym), seq);
} }
for (; scm_is_pair (seq); seq = CDR (seq)) for (; scm_is_pair (seq); seq = CDR (seq))
body = SEQ (src, CAR (seq), body); body = SEQ (CAR (seq), body);
return LAMBDA_CASE 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: 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); names = REF (exp, LET, NAMES);
syms = REF (exp, LET, GENSYMS); syms = REF (exp, LET, GENSYMS);
vals = convert_assignment (REF (exp, LET, VALS), assigned); vals = convert_assignment (REF (exp, LET, VALS), assigned);
@ -1523,28 +1431,26 @@ convert_assignment (SCM exp, SCM assigned)
} }
new_vals = scm_reverse (new_vals); 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: 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); names = REF (exp, LETREC, NAMES);
syms = REF (exp, LETREC, GENSYMS); syms = REF (exp, LETREC, GENSYMS);
vals = convert_assignment (REF (exp, LETREC, VALS), assigned); vals = convert_assignment (REF (exp, LETREC, VALS), assigned);
body = convert_assignment (REF (exp, LETREC, BODY), assigned); body = convert_assignment (REF (exp, LETREC, BODY), assigned);
empty_box = empty_box =
PRIMCALL (SCM_BOOL_F, PRIMCALL (scm_from_latin1_symbol ("make-undefined-variable"),
scm_from_latin1_symbol ("make-undefined-variable"),
SCM_EOL); SCM_EOL);
boxes = scm_make_list (scm_length (names), empty_box); boxes = scm_make_list (scm_length (names), empty_box);
if (scm_is_true (REF (exp, LETREC, IN_ORDER_P))) if (scm_is_true (REF (exp, LETREC, IN_ORDER_P)))
return LET return LET
(src, names, syms, boxes, (names, syms, boxes,
init_boxes (names, syms, vals, body)); init_boxes (names, syms, vals, body));
else else
{ {
@ -1554,17 +1460,16 @@ convert_assignment (SCM exp, SCM assigned)
{ {
SCM tmp = scm_gensym (SCM_UNDEFINED); SCM tmp = scm_gensym (SCM_UNDEFINED);
tmps = scm_cons (tmp, tmps); 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); inits);
} }
tmps = scm_reverse (tmps); tmps = scm_reverse (tmps);
inits = scm_reverse (inits); inits = scm_reverse (inits);
return LET return LET
(src, names, syms, boxes, (names, syms, boxes,
SEQ (src, SEQ (LET (names, tmps, vals,
LET (src, names, tmps, vals, init_boxes (names, syms, inits, VOID_ ())),
init_boxes (names, syms, inits, VOID_ (src))),
body)); body));
} }
} }
@ -1654,7 +1559,7 @@ scm_init_expand ()
exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list); exp_vtable_list = scm_cons (exp_vtables[n], exp_vtable_list);
const_unbound = 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); scm_c_define_gsubr ("convert-assignment", 1, 0, 0, scm_convert_assignment);