mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-07-05 09:10:18 +02:00
Code Activity

DRAFT: Scheme eval: Add source annotations to generated procedures.

Browse source
This commit is contained in:
Mark H Weaver 2019-06-01 02:39:57 -04:00
parent 28c2b44f6d
commit 716e02b85d
6 changed files with 376 additions and 301 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/eval.c
View file

@ -429,7 +429,7 @@ eval (SCM x, SCM env)
SCM var;
var = scm_sys_resolve_variable (mx, env_tail (env));
scm_set_cdr_x (x, var);
SCM_SET_MEMOIZED_ARGS (x, var);
return var;
}

106
libguile/expand.c
View file

@ -380,7 +380,7 @@ expand (SCM exp, SCM env)
return TOPLEVEL_REF (SCM_BOOL_F, exp);
}
else
return CONST_ (SCM_BOOL_F, exp);
return CONST_ (scm_source_properties (exp), exp);
}
static SCM
@ -441,17 +441,21 @@ 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_source_properties (expr), 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),
{
SCM src = scm_source_properties (expr);
return CONDITIONAL (src,
expand (CAR (cdr_expr), env),
expand_and (cdr_expr, env),
CONST_ (SCM_BOOL_F, SCM_BOOL_F));
CONST_ (src, SCM_BOOL_F));
}
}
static SCM
@ -479,7 +483,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_ (scm_source_properties (clause));
else
rest = expand_cond_clauses (CAR (rest), CDR (rest), elp, alp, env);
@ -489,23 +493,23 @@ expand_cond_clauses (SCM clause, SCM rest, int elp, int alp, SCM env)
{
SCM tmp = scm_gensym (scm_from_utf8_string ("cond "));
SCM new_env = scm_acons (tmp, tmp, env);
SCM src = scm_source_properties (clause);
ASSERT_SYNTAX (length > 2, s_missing_recipient, clause);
ASSERT_SYNTAX (length == 3, s_extra_expression, clause);
return LET (SCM_BOOL_F,
return LET (src,
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,
CONDITIONAL (src,
LEXICAL_REF (src, tmp, tmp),
CALL (src,
expand (CADDR (clause), new_env),
scm_list_1 (LEXICAL_REF (SCM_BOOL_F,
tmp, tmp))),
scm_list_1 (LEXICAL_REF (src, tmp, tmp))),
rest));
}
/* FIXME length == 1 case */
else
return CONDITIONAL (SCM_BOOL_F,
return CONDITIONAL (scm_source_properties (clause),
expand (test, env),
expand_sequence (CDR (clause), env),
rest);
@ -580,13 +584,14 @@ expand_if (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = CDR (expr);
const long length = scm_ilength (cdr_expr);
SCM src = scm_source_properties (expr);
ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
return CONDITIONAL (scm_source_properties (expr),
return CONDITIONAL (src,
expand (CADR (expr), env),
expand (CADDR (expr), env),
((length == 3)
? expand (CADDDR (expr), env)
: VOID_ (SCM_BOOL_F)));
: VOID_ (src)));
}
/* A helper function for expand_lambda to support checking for duplicate
@ -664,7 +669,7 @@ 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 (scm_source_properties (clause), req, SCM_BOOL_F, rest, SCM_BOOL_F,
SCM_EOL, vars, body, alternate);
}
@ -843,7 +848,7 @@ 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 (scm_source_properties (clause), req, opt, rest, kw, inits, vars, body,
alternate);
}
@ -963,6 +968,7 @@ expand_named_let (const SCM expr, SCM env)
const SCM name = CAR (cdr_expr);
const SCM cddr_expr = CDR (cdr_expr);
const SCM bindings = CAR (cddr_expr);
const SCM src = scm_source_properties (expr);
check_bindings (bindings, expr);
transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
@ -971,16 +977,16 @@ 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,
(src, SCM_BOOL_F,
scm_list_1 (name), scm_list_1 (name_sym),
scm_list_1 (LAMBDA (SCM_BOOL_F,
scm_list_1 (LAMBDA (src,
SCM_EOL,
LAMBDA_CASE (SCM_BOOL_F, var_names, SCM_EOL, SCM_BOOL_F,
LAMBDA_CASE (src, 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 (src,
LEXICAL_REF (src, name, name_sym),
expand_exprs (inits, env)));
}
@ -1008,7 +1014,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,
return LET (scm_source_properties (expr),
var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr),
expand_env_extend (env, var_names,
@ -1035,7 +1041,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 (scm_source_properties (expr), in_order_p,
var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr), env));
}
@ -1069,7 +1075,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_source_properties (bindings), 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)));
@ -1091,20 +1097,21 @@ expand_or (SCM expr, SCM env SCM_UNUSED)
{
SCM tail = CDR (expr);
const long length = scm_ilength (tail);
SCM src = scm_source_properties (expr);
ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
if (scm_is_null (CDR (expr)))
return CONST_ (SCM_BOOL_F, SCM_BOOL_F);
return CONST_ (src, SCM_BOOL_F);
else
{
SCM tmp = scm_gensym (SCM_UNDEFINED);
return LET (SCM_BOOL_F,
return LET (src,
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 (src,
LEXICAL_REF (src, tmp, tmp),
LEXICAL_REF (src, tmp, tmp),
expand_or (CDR (expr),
scm_acons (tmp, tmp, env))));
}
@ -1277,17 +1284,17 @@ compute_assigned (SCM exp, SCM assigned)
}
static SCM
box_value (SCM exp)
box_value (SCM src, SCM exp)
{
return PRIMCALL (SCM_BOOL_F, scm_from_latin1_symbol ("make-variable"),
return PRIMCALL (src, scm_from_latin1_symbol ("make-variable"),
scm_list_1 (exp));
}
static SCM
box_lexical (SCM name, SCM sym)
box_lexical (SCM src, SCM name, SCM sym)
{
return LEXICAL_SET (SCM_BOOL_F, name, sym,
box_value (LEXICAL_REF (SCM_BOOL_F, name, sym)));
return LEXICAL_SET (src, name, sym,
box_value (src, LEXICAL_REF (SCM_BOOL_F, name, sym)));
}
static SCM
@ -1407,24 +1414,27 @@ convert_assignment (SCM exp, SCM assigned)
convert_assignment (REF (exp, SEQ, TAIL), assigned));
case SCM_EXPANDED_LAMBDA:
{
SCM src = scm_source_properties (exp);
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,
? LAMBDA_CASE (src, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F,
SCM_EOL, SCM_EOL,
PRIMCALL
(SCM_BOOL_F,
(src,
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_list_5 (CONST_ (src, scm_args_number_key),
CONST_ (src, SCM_BOOL_F),
CONST_ (src, scm_from_latin1_string
("Wrong number of arguments")),
CONST_ (SCM_BOOL_F, SCM_EOL),
CONST_ (SCM_BOOL_F, SCM_BOOL_F))),
CONST_ (src, SCM_EOL),
CONST_ (src, SCM_BOOL_F))),
SCM_BOOL_F)
: convert_assignment (REF (exp, LAMBDA, BODY), assigned));
}
case SCM_EXPANDED_LAMBDA_CASE:
{
@ -1456,7 +1466,7 @@ convert_assignment (SCM exp, SCM assigned)
{
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);
seq = scm_cons (box_lexical (src, name, sym), seq);
}
/* Optional arguments may need initialization and/or boxing. */
for (namewalk = opt;
@ -1467,7 +1477,7 @@ convert_assignment (SCM exp, SCM assigned)
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);
seq = scm_cons (box_lexical (src, name, sym), seq);
}
/* Rest arguments may need boxing. */
if (scm_is_true (rest))
@ -1475,7 +1485,7 @@ convert_assignment (SCM exp, SCM assigned)
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);
seq = scm_cons (box_lexical (src, rest, sym), seq);
}
/* The rest of the arguments, if any, are keyword arguments,
which may need initialization and/or boxing. */
@ -1486,7 +1496,7 @@ convert_assignment (SCM exp, SCM assigned)
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);
seq = scm_cons (box_lexical (src, SCM_BOOL_F, sym), seq);
}
for (; scm_is_pair (seq); seq = CDR (seq))
@ -1512,7 +1522,7 @@ convert_assignment (SCM exp, SCM assigned)
{
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);
new_vals = scm_cons (box_value (src, val), new_vals);
else
new_vals = scm_cons (val, new_vals);
}
@ -1532,7 +1542,7 @@ convert_assignment (SCM exp, SCM assigned)
body = convert_assignment (REF (exp, LETREC, BODY), assigned);
empty_box =
PRIMCALL (SCM_BOOL_F,
PRIMCALL (src,
scm_from_latin1_symbol ("make-undefined-variable"),
SCM_EOL);
boxes = scm_make_list (scm_length (names), empty_box);
@ -1549,7 +1559,7 @@ 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 (src, SCM_BOOL_F, tmp),
inits);
}
tmps = scm_reverse (tmps);

205
libguile/memoize.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-2015,2018
/* Copyright 1995-2016,2018,2019
Free Software Foundation, Inc.
This file is part of Guile.
@ -136,15 +136,13 @@ do_pop_dynamic_state (void)
/* {Evaluator memoized expressions}
*/
scm_t_bits scm_tc16_memoized;
#define MAKMEMO(n, src, args) \
(scm_cons (SCM_I_MAKINUM (n), scm_cons (src, args)))
#define MAKMEMO(n, args) \
(scm_cons (SCM_I_MAKINUM (n), args))
#define MAKMEMO_SEQ(head,tail) \
MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
#define MAKMEMO_IF(test, then, else_) \
MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
#define MAKMEMO_SEQ(src, head, tail) \
MAKMEMO (SCM_M_SEQ, src, scm_cons (head, tail))
#define MAKMEMO_IF(src, test, then, else_) \
MAKMEMO (SCM_M_IF, src, scm_cons (test, scm_cons (then, else_)))
#define FIXED_ARITY(nreq) \
scm_list_1 (SCM_I_MAKINUM (nreq))
#define REST_ARITY(nreq, rest) \
@ -152,41 +150,41 @@ scm_t_bits scm_tc16_memoized;
#define FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \
scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \
SCM_I_MAKINUM (ninits), unbound, alt, SCM_UNDEFINED)
#define MAKMEMO_LAMBDA(body, arity, meta) \
MAKMEMO (SCM_M_LAMBDA, \
#define MAKMEMO_LAMBDA(src, body, arity, meta) \
MAKMEMO (SCM_M_LAMBDA, src, \
scm_cons (body, scm_cons (meta, arity)))
#define MAKMEMO_CAPTURE_ENV(vars, body) \
MAKMEMO (SCM_M_CAPTURE_ENV, scm_cons (vars, body))
#define MAKMEMO_LET(inits, body) \
MAKMEMO (SCM_M_LET, scm_cons (inits, body))
#define MAKMEMO_QUOTE(exp) \
MAKMEMO (SCM_M_QUOTE, exp)
#define MAKMEMO_CAPTURE_MODULE(exp) \
MAKMEMO (SCM_M_CAPTURE_MODULE, exp)
#define MAKMEMO_APPLY(proc, args)\
MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
#define MAKMEMO_CONT(proc) \
MAKMEMO (SCM_M_CONT, proc)
#define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
#define MAKMEMO_CALL(proc, args) \
MAKMEMO (SCM_M_CALL, scm_cons (proc, args))
#define MAKMEMO_LEX_REF(pos) \
MAKMEMO (SCM_M_LEXICAL_REF, pos)
#define MAKMEMO_LEX_SET(pos, val) \
MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val))
#define MAKMEMO_BOX_REF(box) \
MAKMEMO (SCM_M_BOX_REF, box)
#define MAKMEMO_BOX_SET(box, val) \
MAKMEMO (SCM_M_BOX_SET, scm_cons (box, val))
#define MAKMEMO_TOP_BOX(mode, var) \
MAKMEMO (SCM_M_RESOLVE, scm_cons (SCM_I_MAKINUM (mode), var))
#define MAKMEMO_MOD_BOX(mode, mod, var, public) \
MAKMEMO (SCM_M_RESOLVE, \
#define MAKMEMO_CAPTURE_ENV(src, vars, body) \
MAKMEMO (SCM_M_CAPTURE_ENV, src, scm_cons (vars, body))
#define MAKMEMO_LET(src, inits, body) \
MAKMEMO (SCM_M_LET, src, scm_cons (inits, body))
#define MAKMEMO_QUOTE(src, exp) \
MAKMEMO (SCM_M_QUOTE, src, exp)
#define MAKMEMO_CAPTURE_MODULE(src, exp) \
MAKMEMO (SCM_M_CAPTURE_MODULE, src, exp)
#define MAKMEMO_APPLY(src, proc, args) \
MAKMEMO (SCM_M_APPLY, src, scm_list_2 (proc, args))
#define MAKMEMO_CONT(src, proc) \
MAKMEMO (SCM_M_CONT, src, proc)
#define MAKMEMO_CALL_WITH_VALUES(src, prod, cons) \
MAKMEMO (SCM_M_CALL_WITH_VALUES, src, scm_cons (prod, cons))
#define MAKMEMO_CALL(src, proc, args) \
MAKMEMO (SCM_M_CALL, src, scm_cons (proc, args))
#define MAKMEMO_LEX_REF(src, pos) \
MAKMEMO (SCM_M_LEXICAL_REF, src, pos)
#define MAKMEMO_LEX_SET(src, pos, val) \
MAKMEMO (SCM_M_LEXICAL_SET, src, scm_cons (pos, val))
#define MAKMEMO_BOX_REF(src, box) \
MAKMEMO (SCM_M_BOX_REF, src, box)
#define MAKMEMO_BOX_SET(src, box, val) \
MAKMEMO (SCM_M_BOX_SET, src, scm_cons (box, val))
#define MAKMEMO_TOP_BOX(src, mode, var) \
MAKMEMO (SCM_M_RESOLVE, src, scm_cons (SCM_I_MAKINUM (mode), var))
#define MAKMEMO_MOD_BOX(src, mode, mod, var, public) \
MAKMEMO (SCM_M_RESOLVE, src, \
scm_cons (SCM_I_MAKINUM (mode), \
scm_cons (mod, scm_cons (var, public))))
#define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
#define MAKMEMO_CALL_WITH_PROMPT(src, tag, thunk, handler) \
MAKMEMO (SCM_M_CALL_WITH_PROMPT, src, scm_cons (tag, scm_cons (thunk, handler)))
@ -332,7 +330,7 @@ lookup (SCM x, SCM env)
}
static SCM
capture_flat_env (SCM lambda, SCM env)
capture_flat_env (SCM src, SCM lambda, SCM env)
{
int nenv;
SCM vars, link, locs;
@ -345,12 +343,16 @@ capture_flat_env (SCM lambda, SCM env)
for (; scm_is_pair (vars); vars = CDR (vars))
scm_c_vector_set_x (locs, --nenv, CDAR (vars));
return MAKMEMO_CAPTURE_ENV (locs, lambda);
return MAKMEMO_CAPTURE_ENV (src, locs, lambda);
}
/* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
#define REF(x,type,field) \
(scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
#define SRC(x) \
(scm_struct_ref (x, SCM_INUM0)) /* WARNING: this assumes that every
expanded structure starts with
its source. */
static SCM list_of_guile = SCM_BOOL_F;
@ -374,56 +376,70 @@ capture_env (SCM env)
}
static SCM
maybe_makmemo_capture_module (SCM exp, SCM env)
maybe_makmemo_capture_module (SCM src, SCM exp, SCM env)
{
if (scm_is_false (env))
return MAKMEMO_CAPTURE_MODULE (exp);
return MAKMEMO_CAPTURE_MODULE (src, exp);
return exp;
}
static SCM
memoize (SCM exp, SCM env)
{
SCM src;
if (!SCM_EXPANDED_P (exp))
abort ();
src = SRC (exp);
switch (SCM_EXPANDED_TYPE (exp))
{
case SCM_EXPANDED_VOID:
return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
return MAKMEMO_QUOTE (src, SCM_UNSPECIFIED);
case SCM_EXPANDED_CONST:
return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
return MAKMEMO_QUOTE (src, REF (exp, CONST, EXP));
case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return maybe_makmemo_capture_module
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
(src,
MAKMEMO_BOX_REF (src,
MAKMEMO_TOP_BOX (src,
SCM_EXPANDED_TOPLEVEL_REF,
REF (exp, PRIMITIVE_REF, NAME))),
env);
else
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
return MAKMEMO_BOX_REF (src,
MAKMEMO_MOD_BOX (src,
SCM_EXPANDED_MODULE_REF,
list_of_guile,
REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F));
case SCM_EXPANDED_LEXICAL_REF:
return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
return MAKMEMO_LEX_REF (src,
lookup (REF (exp, LEXICAL_REF, GENSYM), env));
case SCM_EXPANDED_LEXICAL_SET:
return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
return MAKMEMO_LEX_SET (src,
lookup (REF (exp, LEXICAL_SET, GENSYM), env),
memoize (REF (exp, LEXICAL_SET, EXP), env));
case SCM_EXPANDED_MODULE_REF:
return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX
(SCM_EXPANDED_MODULE_REF,
return MAKMEMO_BOX_REF (src,
MAKMEMO_MOD_BOX
(src,
SCM_EXPANDED_MODULE_REF,
REF (exp, MODULE_REF, MOD),
REF (exp, MODULE_REF, NAME),
REF (exp, MODULE_REF, PUBLIC)));
case SCM_EXPANDED_MODULE_SET:
return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX
(SCM_EXPANDED_MODULE_SET,
return MAKMEMO_BOX_SET (src,
MAKMEMO_MOD_BOX
(src,
SCM_EXPANDED_MODULE_SET,
REF (exp, MODULE_SET, MOD),
REF (exp, MODULE_SET, NAME),
REF (exp, MODULE_SET, PUBLIC)),
@ -431,13 +447,19 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_TOPLEVEL_REF:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
(src,
MAKMEMO_BOX_REF (src,
MAKMEMO_TOP_BOX (src,
SCM_EXPANDED_TOPLEVEL_REF,
REF (exp, TOPLEVEL_REF, NAME))),
env);
case SCM_EXPANDED_TOPLEVEL_SET:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET,
(src,
MAKMEMO_BOX_SET (src,
MAKMEMO_TOP_BOX (src,
SCM_EXPANDED_TOPLEVEL_SET,
REF (exp, TOPLEVEL_SET, NAME)),
memoize (REF (exp, TOPLEVEL_SET, EXP),
capture_env (env))),
@ -445,14 +467,18 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return maybe_makmemo_capture_module
(MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE,
(src,
MAKMEMO_BOX_SET (src,
MAKMEMO_TOP_BOX (src,
SCM_EXPANDED_TOPLEVEL_DEFINE,
REF (exp, TOPLEVEL_DEFINE, NAME)),
memoize (REF (exp, TOPLEVEL_DEFINE, EXP),
capture_env (env))),
env);
case SCM_EXPANDED_CONDITIONAL:
return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
return MAKMEMO_IF (src,
memoize (REF (exp, CONDITIONAL, TEST), env),
memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
@ -463,7 +489,7 @@ memoize (SCM exp, SCM env)
proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, CALL, ARGS), env);
return MAKMEMO_CALL (memoize (proc, env), args);
return MAKMEMO_CALL (src, memoize (proc, env), args);
}
case SCM_EXPANDED_PRIMCALL:
@ -477,59 +503,71 @@ memoize (SCM exp, SCM env)
if (nargs == 3
&& scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
return MAKMEMO_CALL_WITH_PROMPT (src,
CAR (args),
CADR (args),
CADDR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("apply")))
return MAKMEMO_APPLY (CAR (args), CADR (args));
return MAKMEMO_APPLY (src, CAR (args), CADR (args));
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol
("call-with-current-continuation")))
return MAKMEMO_CONT (CAR (args));
return MAKMEMO_CONT (src, CAR (args));
else if (nargs == 2
&& scm_is_eq (name,
scm_from_latin1_symbol ("call-with-values")))
return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
return MAKMEMO_CALL_WITH_VALUES (src, CAR (args), CADR (args));
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol ("variable-ref")))
return MAKMEMO_BOX_REF (CAR (args));
return MAKMEMO_BOX_REF (src, CAR (args));
else if (nargs == 2
&& scm_is_eq (name,
scm_from_latin1_symbol ("variable-set!")))
return MAKMEMO_BOX_SET (CAR (args), CADR (args));
return MAKMEMO_BOX_SET (src, CAR (args), CADR (args));
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("wind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), args);
return MAKMEMO_CALL (src, MAKMEMO_QUOTE (src, wind), args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), SCM_EOL);
return MAKMEMO_CALL (src, MAKMEMO_QUOTE (src, unwind), SCM_EOL);
else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), args);
return MAKMEMO_CALL (src, MAKMEMO_QUOTE (src, push_fluid), args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL);
return MAKMEMO_CALL (src, MAKMEMO_QUOTE (src, pop_fluid), SCM_EOL);
else if (nargs == 1
&& scm_is_eq (name,
scm_from_latin1_symbol ("push-dynamic-state")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (push_dynamic_state), args);
return MAKMEMO_CALL (src,
MAKMEMO_QUOTE (src, push_dynamic_state),
args);
else if (nargs == 0
&& scm_is_eq (name,
scm_from_latin1_symbol ("pop-dynamic-state")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_dynamic_state), SCM_EOL);
return MAKMEMO_CALL (src,
MAKMEMO_QUOTE (src, pop_dynamic_state),
SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (maybe_makmemo_capture_module
(MAKMEMO_BOX_REF
(MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
return MAKMEMO_CALL (src,
maybe_makmemo_capture_module
(src,
MAKMEMO_BOX_REF
(src,
MAKMEMO_TOP_BOX (src,
SCM_EXPANDED_TOPLEVEL_REF,
name)),
env),
args);
else
return MAKMEMO_CALL (MAKMEMO_BOX_REF
(MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
return MAKMEMO_CALL (src,
MAKMEMO_BOX_REF
(src,
MAKMEMO_MOD_BOX (src,
SCM_EXPANDED_MODULE_REF,
list_of_guile,
name,
SCM_BOOL_F)),
@ -537,7 +575,8 @@ memoize (SCM exp, SCM env)
}
case SCM_EXPANDED_SEQ:
return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
return MAKMEMO_SEQ (src,
memoize (REF (exp, SEQ, HEAD), env),
memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA:
@ -551,7 +590,10 @@ memoize (SCM exp, SCM env)
proc = memoize (body, new_env);
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
return maybe_makmemo_capture_module (capture_flat_env (proc, new_env),
return maybe_makmemo_capture_module (src,
capture_flat_env (src,
proc,
new_env),
env);
}
@ -610,7 +652,8 @@ memoize (SCM exp, SCM env)
arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
return MAKMEMO_LAMBDA (src,
memoize (body, new_env), arity,
SCM_EOL /* meta, filled in later */);
}
@ -631,7 +674,7 @@ memoize (SCM exp, SCM env)
VECTOR_SET (inits, i, memoize (CAR (exps), env));
return maybe_makmemo_capture_module
(MAKMEMO_LET (inits, memoize (body, new_env)), env);
(src, MAKMEMO_LET (src, inits, memoize (body, new_env)), env);
}
default:

6
libguile/memoize.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_MEMOIZE_H
#define SCM_MEMOIZE_H
/* Copyright 1995-1996,1998-2002,2004,2008-2011,2013-2014,2018
/* Copyright 1995-1996,1998-2002,2004,2008-2011,2013-2014,2018,2019
Free Software Foundation, Inc.
This file is part of Guile.
@ -57,7 +57,9 @@ SCM_API SCM scm_sym_args;
*/
#define SCM_MEMOIZED_TAG(x) (scm_to_uint16 (scm_car (x)))
#define SCM_MEMOIZED_ARGS(x) (scm_cdr (x))
#define SCM_MEMOIZED_SRC(x) (scm_cadr (x))
#define SCM_MEMOIZED_ARGS(x) (scm_cddr (x))
#define SCM_SET_MEMOIZED_ARGS(x, v) (scm_set_cdr_x (scm_cdr (x), (v)))
enum
{

309
module/ice-9/eval.scm
View file

@ -1,6 +1,6 @@
;;; -*- mode: scheme; coding: utf-8; -*-
;;;; Copyright (C) 2009-2015, 2018 Free Software Foundation, Inc.
;;;; Copyright (C) 2009-2015, 2018, 2019 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -111,19 +111,26 @@
(or (memoized-typecode (syntax->datum #'type))
(error "not a typecode" (syntax->datum #'type)))))))
(define-syntax-rule (lazy (arg ...) exp)
(define (annotate src proc)
(set-procedure-property! proc 'source-override src)
proc)
(define-syntax-rule (lambda@ src formals body bodies ...)
(annotate src (lambda formals body bodies ...)))
(define-syntax-rule (lazy src (arg ...) exp)
(letrec ((proc (lambda (arg ...)
(set! proc exp)
(proc arg ...))))
(lambda (arg ...)
(lambda@ src (arg ...)
(proc arg ...))))
(define (compile-lexical-ref depth width)
(define (compile-lexical-ref src depth width)
(case depth
((0) (lambda (env) (env-ref env 0 width)))
((1) (lambda (env) (env-ref env 1 width)))
((2) (lambda (env) (env-ref env 2 width)))
(else (lambda (env) (env-ref env depth width)))))
((0) (lambda@ src (env) (env-ref env 0 width)))
((1) (lambda@ src (env) (env-ref env 1 width)))
((2) (lambda@ src (env) (env-ref env 2 width)))
(else (lambda@ src (env) (env-ref env depth width)))))
(define (primitive=? name loc module var)
"Return true if VAR is the same as the primitive bound to NAME."
@ -137,7 +144,7 @@
(or (not module)
(eq? var (module-local-variable the-root-module name)))))))
(define (compile-top-call cenv loc args)
(define (compile-top-call src cenv loc args)
(let* ((module (env-toplevel cenv))
(var (%resolve-variable loc module)))
(define-syntax-rule (maybe-primcall (prim ...) arg ...)
@ -145,12 +152,12 @@
...)
(cond
((primitive=? 'prim loc module var)
(lambda (env) (prim (arg env) ...)))
(lambda@ src (env) (prim (arg env) ...)))
...
(else (lambda (env) ((variable-ref var) (arg env) ...))))))
(else (lambda@ src (env) ((variable-ref var) (arg env) ...))))))
(match args
(()
(lambda (env) ((variable-ref var))))
(lambda@ src (env) ((variable-ref var))))
((a)
(maybe-primcall (1+ 1- car cdr lognot vector-length
variable-ref string-length struct-vtable)
@ -169,37 +176,37 @@
(if (null? args)
'()
(cons (compile (car args)) (lp (cdr args)))))))
(lambda (env)
(lambda@ src (env)
(apply (variable-ref var) (a env) (b env) (c env)
(let lp ((args args))
(if (null? args)
'()
(cons ((car args) env) (lp (cdr args))))))))))))
(define (compile-call f args)
(define (compile-call src f args)
(match f
((,(typecode box-ref) . (,(typecode resolve) . loc))
(lazy (env) (compile-top-call env loc args)))
((,(typecode box-ref) _ . (,(typecode resolve) _ . loc))
(lazy src (env) (compile-top-call src env loc args)))
(_
(match args
(()
(let ((f (compile f)))
(lambda (env) ((f env)))))
(lambda@ src (env) ((f env)))))
((a)
(let ((f (compile f))
(a (compile a)))
(lambda (env) ((f env) (a env)))))
(lambda@ src (env) ((f env) (a env)))))
((a b)
(let ((f (compile f))
(a (compile a))
(b (compile b)))
(lambda (env) ((f env) (a env) (b env)))))
(lambda@ src (env) ((f env) (a env) (b env)))))
((a b c)
(let ((f (compile f))
(a (compile a))
(b (compile b))
(c (compile c)))
(lambda (env) ((f env) (a env) (b env) (c env)))))
(lambda@ src (env) ((f env) (a env) (b env) (c env)))))
((a b c . args)
(let ((f (compile f))
(a (compile a))
@ -209,46 +216,46 @@
(if (null? args)
'()
(cons (compile (car args)) (lp (cdr args)))))))
(lambda (env)
(lambda@ src (env)
(apply (f env) (a env) (b env) (c env)
(let lp ((args args))
(if (null? args)
'()
(cons ((car args) env) (lp (cdr args)))))))))))))
(define (compile-box-ref box)
(define (compile-box-ref src box)
(match box
((,(typecode resolve) . loc)
(lazy (cenv)
((,(typecode resolve) _ . loc)
(lazy src (cenv)
(let ((var (%resolve-variable loc (env-toplevel cenv))))
(lambda (env) (variable-ref var)))))
((,(typecode lexical-ref) depth . width)
(lambda (env)
(lambda@ src (env) (variable-ref var)))))
((,(typecode lexical-ref) _ depth . width)
(lambda@ src (env)
(variable-ref (env-ref env depth width))))
(_
(let ((box (compile box)))
(lambda (env)
(lambda@ src (env)
(variable-ref (box env)))))))
(define (compile-resolve cenv loc)
(define (compile-resolve src cenv loc)
(let ((var (%resolve-variable loc (env-toplevel cenv))))
(lambda (env) var)))
(lambda@ src (env) var)))
(define (compile-top-branch cenv loc args consequent alternate)
(define (compile-top-branch src cenv loc args consequent alternate)
(let* ((module (env-toplevel cenv))
(var (%resolve-variable loc module))
(consequent (compile consequent))
(alternate (compile alternate)))
(define (generic-top-branch)
(let ((test (compile-top-call cenv loc args)))
(lambda (env)
(let ((test (compile-top-call src cenv loc args)))
(lambda@ src (env)
(if (test env) (consequent env) (alternate env)))))
(define-syntax-rule (maybe-primcall (prim ...) arg ...)
(cond
((primitive=? 'prim loc module var)
(let ((arg (compile arg))
...)
(lambda (env)
(lambda@ src (env)
(if (prim (arg env) ...)
(consequent env)
(alternate env)))))
@ -265,94 +272,94 @@
(_
(generic-top-branch)))))
(define (compile-if test consequent alternate)
(define (compile-if src test consequent alternate)
(match test
((,(typecode call)
(,(typecode box-ref) . (,(typecode resolve) . loc))
((,(typecode call) _
(,(typecode box-ref) _ . (,(typecode resolve) _ . loc))
. args)
(lazy (env) (compile-top-branch env loc args consequent alternate)))
(lazy src (env) (compile-top-branch src env loc args consequent alternate)))
(_
(let ((test (compile test))
(consequent (compile consequent))
(alternate (compile alternate)))
(lambda (env)
(lambda@ src (env)
(if (test env) (consequent env) (alternate env)))))))
(define (compile-quote x)
(lambda (env) x))
(define (compile-quote src x)
(lambda@ src (env) x))
(define (compile-let inits body)
(define (compile-let src inits body)
(let ((body (compile body))
(width (vector-length inits)))
(case width
((0) (lambda (env)
((0) (lambda@ src (env)
(body (make-env* env))))
((1)
(let ((a (compile (vector-ref inits 0))))
(lambda (env)
(lambda@ src (env)
(body (make-env* env (a env))))))
((2)
(let ((a (compile (vector-ref inits 0)))
(b (compile (vector-ref inits 1))))
(lambda (env)
(lambda@ src (env)
(body (make-env* env (a env) (b env))))))
((3)
(let ((a (compile (vector-ref inits 0)))
(b (compile (vector-ref inits 1)))
(c (compile (vector-ref inits 2))))
(lambda (env)
(lambda@ src (env)
(body (make-env* env (a env) (b env) (c env))))))
((4)
(let ((a (compile (vector-ref inits 0)))
(b (compile (vector-ref inits 1)))
(c (compile (vector-ref inits 2)))
(d (compile (vector-ref inits 3))))
(lambda (env)
(lambda@ src (env)
(body (make-env* env (a env) (b env) (c env) (d env))))))
(else
(let lp ((n width)
(k (lambda (env)
(k (lambda@ src (env)
(make-env width #f env))))
(if (zero? n)
(lambda (env)
(lambda@ src (env)
(body (k env)))
(lp (1- n)
(let ((init (compile (vector-ref inits (1- n)))))
(lambda (env)
(lambda@ src (env)
(let* ((x (init env))
(new-env (k env)))
(env-set! new-env 0 (1- n) x)
new-env))))))))))
(define (compile-fixed-lambda body nreq)
(define (compile-fixed-lambda src body nreq)
(case nreq
((0) (lambda (env)
(lambda ()
((0) (lambda@ src (env)
(lambda@ src ()
(body (make-env* env)))))
((1) (lambda (env)
(lambda (a)
((1) (lambda@ src (env)
(lambda@ src (a)
(body (make-env* env a)))))
((2) (lambda (env)
(lambda (a b)
((2) (lambda@ src (env)
(lambda@ src (a b)
(body (make-env* env a b)))))
((3) (lambda (env)
(lambda (a b c)
((3) (lambda@ src (env)
(lambda@ src (a b c)
(body (make-env* env a b c)))))
((4) (lambda (env)
(lambda (a b c d)
((4) (lambda@ src (env)
(lambda@ src (a b c d)
(body (make-env* env a b c d)))))
((5) (lambda (env)
(lambda (a b c d e)
((5) (lambda@ src (env)
(lambda@ src (a b c d e)
(body (make-env* env a b c d e)))))
((6) (lambda (env)
(lambda (a b c d e f)
((6) (lambda@ src (env)
(lambda@ src (a b c d e f)
(body (make-env* env a b c d e f)))))
((7) (lambda (env)
(lambda (a b c d e f g)
((7) (lambda@ src (env)
(lambda@ src (a b c d e f g)
(body (make-env* env a b c d e f g)))))
(else
(lambda (env)
(lambda (a b c d e f g . more)
(lambda@ src (env)
(lambda@ src (a b c d e f g . more)
(let ((env (make-env nreq #f env)))
(env-set! env 0 0 a)
(env-set! env 0 1 b)
@ -377,23 +384,23 @@
(env-set! env 0 n (car args))
(lp (1+ n) (cdr args)))))))))))
(define (compile-rest-lambda body nreq rest?)
(define (compile-rest-lambda src body nreq rest?)
(case nreq
((0) (lambda (env)
(lambda rest
((0) (lambda@ src (env)
(lambda@ src rest
(body (make-env* env rest)))))
((1) (lambda (env)
(lambda (a . rest)
((1) (lambda@ src (env)
(lambda@ src (a . rest)
(body (make-env* env a rest)))))
((2) (lambda (env)
(lambda (a b . rest)
((2) (lambda@ src (env)
(lambda@ src (a b . rest)
(body (make-env* env a b rest)))))
((3) (lambda (env)
(lambda (a b c . rest)
((3) (lambda@ src (env)
(lambda@ src (a b c . rest)
(body (make-env* env a b c rest)))))
(else
(lambda (env)
(lambda (a b c . more)
(lambda@ src (env)
(lambda@ src (a b c . more)
(let ((env (make-env (1+ nreq) #f env)))
(env-set! env 0 0 a)
(env-set! env 0 1 b)
@ -411,10 +418,10 @@
(env-set! env 0 n (car args))
(lp (1+ n) (cdr args)))))))))))
(define (compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)
(lambda (env)
(define (compile-opt-lambda src body nreq rest? nopt ninits unbound make-alt)
(lambda@ src (env)
(define alt (and make-alt (make-alt env)))
(lambda args
(lambda@ src args
(let ((nargs (length args)))
(cond
((or (< nargs nreq) (and (not rest?) (> nargs (+ nreq nopt))))
@ -449,12 +456,12 @@
(body env))
(bind-req args))))))))
(define (compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
(define (compile-kw-lambda src body nreq rest? nopt kw ninits unbound make-alt)
(define allow-other-keys? (car kw))
(define keywords (cdr kw))
(lambda (env)
(lambda@ src (env)
(define alt (and make-alt (make-alt env)))
(lambda args
(lambda@ src args
(define (npositional args)
(let lp ((n 0) (args args))
(if (or (null? args)
@ -557,7 +564,7 @@
(lp alt* nreq* nopt* rest?*)
(lp alt* nreq nopt rest?))))))
(define (compile-general-lambda body nreq rest? nopt kw ninits unbound alt)
(define (compile-general-lambda src body nreq rest? nopt kw ninits unbound alt)
(call-with-values
(lambda ()
(compute-arity alt nreq rest? nopt kw))
@ -566,42 +573,42 @@
(match alt
(#f #f)
((body meta nreq . tail)
(compile-lambda body meta nreq tail))))
(compile-lambda src body meta nreq tail))))
(define make-closure
(if kw
(compile-kw-lambda body nreq rest? nopt kw ninits unbound make-alt)
(compile-opt-lambda body nreq rest? nopt ninits unbound make-alt)))
(lambda (env)
(compile-kw-lambda src body nreq rest? nopt kw ninits unbound make-alt)
(compile-opt-lambda src body nreq rest? nopt ninits unbound make-alt)))
(lambda@ src (env)
(let ((proc (make-closure env)))
(set-procedure-property! proc 'arglist arglist)
(set-procedure-minimum-arity! proc min-nreq min-nopt min-rest?)
proc)))))
(define (compile-lambda body meta nreq tail)
(define (compile-lambda src body meta nreq tail)
(define (set-procedure-meta meta proc)
(match meta
(() proc)
(((prop . val) . meta)
(set-procedure-meta meta
(lambda (env)
(lambda@ src (env)
(let ((proc (proc env)))
(set-procedure-property! proc prop val)
proc))))))
(let ((body (lazy (env) (compile body))))
(let ((body (lazy src (env) (compile body))))
(set-procedure-meta
meta
(match tail
(() (compile-fixed-lambda body nreq))
(() (compile-fixed-lambda src body nreq))
((rest? . tail)
(match tail
(() (compile-rest-lambda body nreq rest?))
(() (compile-rest-lambda src body nreq rest?))
((nopt kw ninits unbound alt)
(compile-general-lambda body nreq rest? nopt kw
(compile-general-lambda src body nreq rest? nopt kw
ninits unbound alt))))))))
(define (compile-capture-env locs body)
(define (compile-capture-env src locs body)
(let ((body (compile body)))
(lambda (env)
(lambda@ src (env)
(let* ((len (vector-length locs))
(new-env (make-env len #f (env-toplevel env))))
(let lp ((n 0))
@ -612,107 +619,107 @@
(lp (1+ n))))
(body new-env)))))
(define (compile-seq head tail)
(define (compile-seq src head tail)
(let ((head (compile head))
(tail (compile tail)))
(lambda (env)
(lambda@ src (env)
(head env)
(tail env))))
(define (compile-box-set! box val)
(define (compile-box-set! src box val)
(let ((box (compile box))
(val (compile val)))
(lambda (env)
(lambda@ src (env)
(let ((val (val env)))
(variable-set! (box env) val)))))
(define (compile-lexical-set! depth width x)
(define (compile-lexical-set! src depth width x)
(let ((x (compile x)))
(lambda (env)
(lambda@ src (env)
(env-set! env depth width (x env)))))
(define (compile-call-with-values producer consumer)
(define (compile-call-with-values src producer consumer)
(let ((producer (compile producer))
(consumer (compile consumer)))
(lambda (env)
(lambda@ src (env)
(call-with-values (producer env)
(consumer env)))))
(define (compile-apply f args)
(define (compile-apply src f args)
(let ((f (compile f))
(args (compile args)))
(lambda (env)
(lambda@ src (env)
(apply (f env) (args env)))))
(define (compile-capture-module x)
(define (compile-capture-module src x)
(let ((x (compile x)))
(lambda (env)
(lambda@ src (env)
(x (current-module)))))
(define (compile-call-with-prompt tag thunk handler)
(define (compile-call-with-prompt src tag thunk handler)
(let ((tag (compile tag))
(thunk (compile thunk))
(handler (compile handler)))
(lambda (env)
(lambda@ src (env)
(call-with-prompt (tag env) (thunk env) (handler env)))))
(define (compile-call/cc proc)
(define (compile-call/cc src proc)
(let ((proc (compile proc)))
(lambda (env)
(lambda@ src (env)
(call/cc (proc env)))))
(define (compile exp)
(match exp
((,(typecode lexical-ref) depth . width)
(compile-lexical-ref depth width))
((,(typecode lexical-ref) src depth . width)
(compile-lexical-ref src depth width))
((,(typecode call) f . args)
(compile-call f args))
((,(typecode call) src f . args)
(compile-call src f args))
((,(typecode box-ref) . box)
(compile-box-ref box))
((,(typecode box-ref) src . box)
(compile-box-ref src box))
((,(typecode resolve) . loc)
(lazy (env) (compile-resolve env loc)))
((,(typecode resolve) src . loc)
(lazy src (env) (compile-resolve src env loc)))
((,(typecode if) test consequent . alternate)
(compile-if test consequent alternate))
((,(typecode if) src test consequent . alternate)
(compile-if src test consequent alternate))
((,(typecode quote) . x)
(compile-quote x))
((,(typecode quote) src . x)
(compile-quote src x))
((,(typecode let) inits . body)
(compile-let inits body))
((,(typecode let) src inits . body)
(compile-let src inits body))
((,(typecode lambda) body meta nreq . tail)
(compile-lambda body meta nreq tail))
((,(typecode lambda) src body meta nreq . tail)
(compile-lambda src body meta nreq tail))
((,(typecode capture-env) locs . body)
(compile-capture-env locs body))
((,(typecode capture-env) src locs . body)
(compile-capture-env src locs body))
((,(typecode seq) head . tail)
(compile-seq head tail))
((,(typecode seq) src head . tail)
(compile-seq src head tail))
((,(typecode box-set!) box . val)
(compile-box-set! box val))
((,(typecode box-set!) src box . val)
(compile-box-set! src box val))
((,(typecode lexical-set!) (depth . width) . x)
(compile-lexical-set! depth width x))
((,(typecode lexical-set!) src (depth . width) . x)
(compile-lexical-set! src depth width x))
((,(typecode call-with-values) producer . consumer)
(compile-call-with-values producer consumer))
((,(typecode call-with-values) src producer . consumer)
(compile-call-with-values src producer consumer))
((,(typecode apply) f args)
(compile-apply f args))
((,(typecode apply) src f args)
(compile-apply src f args))
((,(typecode capture-module) . x)
(compile-capture-module x))
((,(typecode capture-module) src . x)
(compile-capture-module src x))
((,(typecode call-with-prompt) tag thunk . handler)
(compile-call-with-prompt tag thunk handler))
((,(typecode call-with-prompt) src tag thunk . handler)
(compile-call-with-prompt src tag thunk handler))
((,(typecode call/cc) . proc)
(compile-call/cc proc))))
((,(typecode call/cc) src . proc)
(compile-call/cc src proc))))
(let ((eval (compile
(memoize-expression
@ -721,3 +728,7 @@
((module-transformer (current-module)) exp)))))
(env #f))
(eval env)))
;;; Local Variables:
;;; eval: (put 'lambda@ 'scheme-indent-function 2)
;;; End:

13
module/system/vm/program.scm
View file

@ -267,9 +267,18 @@ lists."
;; procedure property interface.
(name (or (and program (procedure-name program))
(and pdi (program-debug-info-name pdi))))
(source (match (find-program-sources addr)
(source (let ((source-override
(procedure-property program 'source-override)))
(if (and source-override
(not (null? source-override))) ; I think the () case didn't occur in 2.2. What's up with that?
((@@ (system vm debug) make-source) ; XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
0
(assq-ref source-override 'filename)
(assq-ref source-override 'line)
(assq-ref source-override 'column))
(match (find-program-sources addr)
(() #f)
((source . _) source)))
((source . _) source)))))
(formals (if program
(program-arguments-alists program)
(let ((arities (find-program-arities addr)))