wingo pushed a commit to branch wip-whippet
in repository guile.
commit 71d112cdde944a89ac06f6bf0a80586a5a1c2022
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Mon May 12 14:06:06 2025 +0200
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.
---
libguile/expand.c | 355 ++++++++++++++++++++----------------------------------
1 file changed, 130 insertions(+), 225 deletions(-)
diff --git a/libguile/expand.c b/libguile/expand.c
index a308b9518..be95578e3 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -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);
