From d89f371c301ee0ac3a09bb152208aa61be2cb285 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Tue, 13 Nov 2018 20:45:10 -0800
Subject: copy-fun: duplicate a function, with own environment.

* eval.c (deep_copy_env): New function.
(eval_init): Register copy-fun intrinsic.

* eval.h (deep_copy_env): Declared.

* lib.c (copy_fun): New function.

* lib.h (copy_fun): Declared.

* vm.c (vm_copy_closure): New function.

* vm.h (vm_copy_closure): Declared.

* txr.1: Documented copy-fun.
---
 eval.c | 17 +++++++++++++++++
 eval.h |  1 +
 lib.c  | 15 +++++++++++++++
 lib.h  |  1 +
 txr.1  | 36 ++++++++++++++++++++++++++++++++++++
 vm.c   | 26 ++++++++++++++++++++++++++
 vm.h   |  1 +
 7 files changed, 97 insertions(+)

diff --git a/eval.c b/eval.c
index 32e26b53..6053c853 100644
--- a/eval.c
+++ b/eval.c
@@ -138,6 +138,22 @@ val copy_env(val oenv)
   }
 }
 
+val deep_copy_env(val oenv)
+{
+  type_check(lit("deep-copy-env"), oenv, ENV);
+
+  {
+    val nenv = make_obj();
+    nenv->e.type = ENV;
+    nenv->e.vbindings = copy_alist(oenv->e.vbindings);
+    nenv->e.fbindings = copy_alist(oenv->e.fbindings);
+
+    nenv->e.up_env = if2(oenv->e.up_env != nil,
+                         deep_copy_env(oenv->e.up_env));
+    return nenv;
+  }
+}
+
 /*
  * Wrapper for performance reasons: don't make make_env
  * process default arguments.
@@ -6745,6 +6761,7 @@ void eval_init(void)
   reg_fun(intern(lit("special-operator-p"), user_package), func_n1(special_operator_p));
   reg_fun(intern(lit("special-var-p"), user_package), func_n1(special_var_p));
   reg_fun(sys_mark_special_s, func_n1(mark_special));
+  reg_fun(intern(lit("copy-fun"), user_package), func_n1(copy_fun));
   reg_fun(intern(lit("func-get-form"), user_package), func_n1(func_get_form));
   reg_fun(intern(lit("func-get-name"), user_package), func_n2o(func_get_name, 1));
   reg_fun(intern(lit("func-get-env"), user_package), func_n1(func_get_env));
diff --git a/eval.h b/eval.h
index 6a69714d..d85d9fb6 100644
--- a/eval.h
+++ b/eval.h
@@ -44,6 +44,7 @@ val set_last_form_evaled(val form);
 void error_trace(val exsym, val exvals, val out_stream, val prefix);
 val make_env(val fbindings, val vbindings, val up_env);
 val copy_env(val oenv);
+val deep_copy_env(val oenv);
 val env_fbind(val env, val sym, val fun);
 val env_vbind(val env, val sym, val obj);
 val lookup_var(val env, val sym);
diff --git a/lib.c b/lib.c
index 33eddfe9..3d17a562 100644
--- a/lib.c
+++ b/lib.c
@@ -6129,6 +6129,21 @@ val func_vm(val closure, val desc, int fixparam, int reqargs, int variadic)
   return obj;
 }
 
+val copy_fun(val ofun)
+{
+  val self = lit("copy-fun");
+  type_check(self, ofun, FUN);
+  {
+    val nfun = make_obj();
+    nfun->f = ofun->f;
+
+    if (nfun->f.env)
+      nfun->f.env = if3(nfun->f.functype == FVM,
+                        vm_copy_closure, deep_copy_env)(nfun->f.env);
+    return nfun;
+  }
+}
+
 val func_get_form(val fun)
 {
   val self = lit("func-get-form");
diff --git a/lib.h b/lib.h
index 1d6488d3..c6973252 100644
--- a/lib.h
+++ b/lib.h
@@ -904,6 +904,7 @@ val func_n2ov(val (*fun)(val, val, varg), int reqargs);
 val func_n3ov(val (*fun)(val, val, val, varg), int reqargs);
 val func_interp(val env, val form);
 val func_vm(val closure, val desc, int fixparam, int reqargs, int variadic);
+val copy_fun(val ofun);
 val func_get_form(val fun);
 val func_get_env(val fun);
 val func_set_env(val fun, val env);
diff --git a/txr.1 b/txr.1
index 22a1913b..1aac81f8 100644
--- a/txr.1
+++ b/txr.1
@@ -14207,6 +14207,42 @@ argument is not given any special syntactic treatment at all)
 while the Lisp-2 foundation provides a traditional Lisp environment with its
 "natural hygiene".
 
+.coNP Function @ copy-fun
+.synb
+.mets (copy-fun << function )
+.syne
+.desc
+The
+.code copy-fun
+function produces and returns a duplicate of
+.metn function ,
+which must be a function.
+
+A duplicate of a function is a distinct function object not
+.code eq
+to the original function, yet which accepts the same arguments
+and behaves exactly the same way as the original.
+
+If a function contains no captured environment, then a copy made of that
+function by
+.code copy-fun
+is indistinguishable from the original function in every regard,
+except for being a distinct object that compares unequal to the original
+under the
+.code eq
+function.
+
+If a function contains a captured environment, then a copy of that function
+made by
+.code copy-fun
+has its own copy of that environment. If the copied function changes the
+values of captured lexical variables, the original function is not affected by
+these changes and
+.IR "vice versa" .
+
+The entire lexical environment is copied; the copy and original function do not
+share any portion of the environment at any level of nesting.
+
 .SS* Sequencing, Selection and Iteration
 .coNP Operators @ progn and @ prog1
 .synb
diff --git a/vm.c b/vm.c
index c5a0ed17..9322cba8 100644
--- a/vm.c
+++ b/vm.c
@@ -292,6 +292,32 @@ static val vm_make_closure(struct vm *vm, int frsz)
   return closure;
 }
 
+val vm_copy_closure(val oclosure)
+{
+  struct vm_closure *ovc = coerce(struct vm_closure *, oclosure->co.handle);
+  const size_t hdr_sz = offsetof (struct vm_closure, dspl);
+  size_t dspl_sz = ovc->nlvl * sizeof (struct vm_env);
+  struct vm_closure *nvc = coerce(struct vm_closure *,
+                                  chk_malloc(hdr_sz + dspl_sz));
+  val nclosure;
+  int i;
+
+  memcpy(nvc, ovc, hdr_sz + dspl_sz);
+
+  nclosure = cobj(coerce(mem_t *, nvc), vm_closure_s, &vm_closure_ops);
+
+  for (i = 2; i < nvc->nlvl; i++) {
+    struct vm_env *ndi = &nvc->dspl[i];
+
+    if (ndi->vec != nil) {
+      ndi->vec = copy_vec(ndi->vec);
+      ndi->mem = ndi->vec->v.vec;
+    }
+  }
+
+  return nclosure;
+}
+
 static void vm_closure_mark(val obj)
 {
   struct vm_closure *vc = coerce(struct vm_closure *, obj->co.handle);
diff --git a/vm.h b/vm.h
index 30720d0d..e39b115f 100644
--- a/vm.h
+++ b/vm.h
@@ -30,6 +30,7 @@ extern val vm_desc_s, vm_closure_s;
 val vm_make_desc(val nlevels, val nregs, val bytecode,
                  val datavec, val funvec);
 val vm_execute_toplevel(val desc);
+val vm_copy_closure(val closure);
 val vm_execute_closure(val fun, struct args *);
 void vm_invalidate_binding(val sym);
 void vm_init(void);
-- 
cgit v1.2.3