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

6 files changed, 376 insertions, 301 deletions

diff --git a/libguile/eval.c b/libguile/eval.c
index db6d3a5e9..db8d8bbe6 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 dd6eab0fe..08d411059 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 d9e614f62..79a47e4c2 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 a68f2b403..c78c2e333 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 41224517f..0bc35c499 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 e5dbcc089..5a53d609e 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)))