[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/07: DRAFT: Scheme eval: Add source annotations to gen
|
From: |
Mark H. Weaver |
|
Subject: |
[Guile-commits] 02/07: DRAFT: Scheme eval: Add source annotations to generated procedures. |
|
Date: |
Thu, 6 Jun 2019 05:37:13 -0400 (EDT) |
mhw pushed a commit to branch wip-new-tagging
in repository guile.
commit 716e02b85dfee95dfddb5ef57999bfb006276ff4
Author: Mark H Weaver <address@hidden>
Date: Sat Jun 1 02:39:57 2019 -0400
DRAFT: Scheme eval: Add source annotations to generated procedures.
---
libguile/eval.c | 2 +-
libguile/expand.c | 132 +++++++++---------
libguile/memoize.c | 209 +++++++++++++++++------------
libguile/memoize.h | 8 +-
module/ice-9/eval.scm | 311 ++++++++++++++++++++++---------------------
module/system/vm/program.scm | 15 ++-
6 files changed, 376 insertions(+), 301 deletions(-)
diff --git a/libguile/eval.c b/libguile/eval.c
index db6d3a5..db8d8bb 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -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;
}
diff --git a/libguile/expand.c b/libguile/expand.c
index dd6eab0..08d4110 100644
--- a/libguile/expand.c
+++ b/libguile/expand.c
@@ -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),
- expand (CAR (cdr_expr), env),
- expand_and (cdr_expr, env),
- CONST_ (SCM_BOOL_F, SCM_BOOL_F));
+ {
+ SCM src = scm_source_properties (expr);
+
+ return CONDITIONAL (src,
+ expand (CAR (cdr_expr), env),
+ expand_and (cdr_expr, env),
+ 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:
- return LAMBDA
- (REF (exp, LAMBDA, SRC),
- REF (exp, LAMBDA, META),
- scm_is_false (REF (exp, LAMBDA, BODY))
- /* Give a body to case-lambda with no clauses. */
- ? LAMBDA_CASE (SCM_BOOL_F, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F,
- SCM_EOL, SCM_EOL,
- PRIMCALL
- (SCM_BOOL_F,
- scm_from_latin1_symbol ("throw"),
- scm_list_5 (CONST_ (SCM_BOOL_F, scm_args_number_key),
- CONST_ (SCM_BOOL_F, SCM_BOOL_F),
- CONST_ (SCM_BOOL_F, scm_from_latin1_string
- ("Wrong number of arguments")),
- CONST_ (SCM_BOOL_F, SCM_EOL),
- CONST_ (SCM_BOOL_F, SCM_BOOL_F))),
- SCM_BOOL_F)
- : convert_assignment (REF (exp, LAMBDA, BODY), assigned));
+ {
+ 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 (src, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F,
+ SCM_EOL, SCM_EOL,
+ PRIMCALL
+ (src,
+ scm_from_latin1_symbol ("throw"),
+ 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_ (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);
diff --git a/libguile/memoize.c b/libguile/memoize.c
index d9e614f..79a47e4 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-2015,2018
+/* Copyright 1995-2016,2018,2019
Free Software Foundation, Inc.
This file is part of Guile.
@@ -136,57 +136,55 @@ 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) \
scm_list_2 (SCM_I_MAKINUM (nreq), rest)
-#define FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \
- scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \
+#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:
diff --git a/libguile/memoize.h b/libguile/memoize.h
index a68f2b4..c78c2e3 100644
--- a/libguile/memoize.h
+++ b/libguile/memoize.h
@@ -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.
@@ -56,8 +56,10 @@ SCM_API SCM scm_sym_args;
/* {Memoized Source}
*/
-#define SCM_MEMOIZED_TAG(x) (scm_to_uint16 (scm_car (x)))
-#define SCM_MEMOIZED_ARGS(x) (scm_cdr (x))
+#define SCM_MEMOIZED_TAG(x) (scm_to_uint16 (scm_car (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
{
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 4122451..0bc35c4 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -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)
- (let ((var (%resolve-variable loc (env-toplevel cenv))))
- (lambda (env) (variable-ref var)))))
- ((,(typecode lexical-ref) depth . width)
- (lambda (env)
+ ((,(typecode resolve) _ . loc)
+ (lazy src (cenv)
+ (let ((var (%resolve-variable loc (env-toplevel cenv))))
+ (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:
diff --git a/module/system/vm/program.scm b/module/system/vm/program.scm
index e5dbcc0..5a53d60 100644
--- a/module/system/vm/program.scm
+++ b/module/system/vm/program.scm
@@ -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)
- (() #f)
- ((source . _) source)))
+ (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)))))
(formals (if program
(program-arguments-alists program)
(let ((arities (find-program-arities addr)))
- [Guile-commits] branch wip-new-tagging created (now f08e08b), Mark H. Weaver, 2019/06/06
- [Guile-commits] 01/07: fix typo, Mark H. Weaver, 2019/06/06
- [Guile-commits] 05/07: DRAFT: Change f64->scm into an intrinsic., Mark H. Weaver, 2019/06/06
- [Guile-commits] 07/07: DRAFT: Add immediate fractions (fixrats)., Mark H. Weaver, 2019/06/06
- [Guile-commits] 03/07: DRAFT: Use 'eqv?' instead of 'eq?' in intmap.scm, intset.scm, etc., Mark H. Weaver, 2019/06/06
- [Guile-commits] 06/07: DRAFT: Add immediate floats (iflos)., Mark H. Weaver, 2019/06/06
- [Guile-commits] 02/07: DRAFT: Scheme eval: Add source annotations to generated procedures.,
Mark H. Weaver <=
- [Guile-commits] 04/07: WIP: New tagging v8, Mark H. Weaver, 2019/06/06