From 6b5958a0731236ea9c51e0d0b47fb408a14d5d09 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 8 Feb 2017 19:18:57 -0800
Subject: New system function: expand-with-free-refs.

This interface to the expander returns not only the expanded
form, but also a list of the free variables and functions
occurring in that form.

This interface to the expander works by installing a handler
which intercepts and muffles warnings.  When a warning occurs
indicating an unbound variable or function, the information is
retained.  The expander then returns the information along
with the expanded form.

* eval.c (gather_free_refs): New static function.
(expand_with_free_refs): New function.
(eval_init): Register sys:expand-with-free-refs intrinsic.
---
 eval.c | 35 +++++++++++++++++++++++++++++++++++
 1 file changed, 35 insertions(+)

diff --git a/eval.c b/eval.c
index c11b2cf2..ca4bed57 100644
--- a/eval.c
+++ b/eval.c
@@ -4266,6 +4266,40 @@ static val no_warn_expand(val form, val menv)
   return ret;
 }
 
+static val gather_free_refs(val info_cons, val exc, struct args *args)
+{
+  (void) exc;
+
+  if (args_count(args) == 2) {
+    val sym = args_get_rest(args, 2);
+    val tag = args_at(args, 1);
+
+    if (tag == var_s) {
+      loc al = car_l(info_cons);
+      if (!memq(sym, deref(al)))
+        mpush(sym, al);
+    } else if (tag == fun_s) {
+      loc dl = cdr_l(info_cons);
+      if (!memq(sym, deref(dl)))
+        mpush(sym, dl);
+    }
+  }
+
+  uw_throw(continue_s, nil);
+}
+
+static val expand_with_free_refs(val form, val menv)
+{
+  val ret;
+  uw_frame_t uw_handler;
+  val info_cons = cons(nil, nil);
+  uw_push_handler(&uw_handler, cons(warning_s, nil),
+                  func_f1v(info_cons, gather_free_refs));
+  ret = expand(form, menv);
+  uw_pop_frame(&uw_handler);
+  return list(ret, car(info_cons), cdr(info_cons), nao);
+}
+
 val macro_form_p(val form, val menv)
 {
   menv = default_bool_arg(menv);
@@ -5671,6 +5705,7 @@ void eval_init(void)
   reg_var(load_path_s, nil);
   reg_symacro(intern(lit("self-load-path"), user_package), load_path_s);
   reg_fun(intern(lit("expand"), system_package), func_n2o(no_warn_expand, 1));
+  reg_fun(intern(lit("expand-with-free-refs"), system_package), func_n2o(expand_with_free_refs, 1));
   reg_fun(intern(lit("macro-form-p"), user_package), func_n2o(macro_form_p, 1));
   reg_fun(intern(lit("macroexpand-1"), user_package),
           func_n2o(macroexpand_1, 1));
-- 
cgit v1.2.3