diff options
-rw-r--r-- | eval.c | 17 | ||||
-rw-r--r-- | eval.h | 1 | ||||
-rw-r--r-- | lib.c | 15 | ||||
-rw-r--r-- | lib.h | 1 | ||||
-rw-r--r-- | txr.1 | 36 | ||||
-rw-r--r-- | vm.c | 26 | ||||
-rw-r--r-- | vm.h | 1 |
7 files changed, 97 insertions, 0 deletions
@@ -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)); @@ -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); @@ -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"); @@ -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); @@ -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 @@ -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); @@ -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); |