From 97d33f4725784e2e98936327e59bb878463965f2 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 21 Mar 2018 22:18:34 -0700
Subject: new special op sys:upenv

This is something that will be useful in compiling some forms.
At first I added it to the compiler only, but it seems wise to
have it in the interpreter also. (sys:upenv form) causes
form to be treated as if it were not in the immediately
surrounding lexical environment but its parent.
Thus (let ((a 1)) (let ((a 2)) (list a (sys:upenv a))))
yields (2 1).  This operator needs no special treatment in the
expander; it is expanded as a function call. This is not 100%
correct in the face of all conceivable use. For instance
given (symacrolet ((a 1)) (let ((a 2)) (sys:upenv a))),
we probably want sys:upenv to skip the inner environment at
expansion time too so that a is replaced by 1. However, it
is not documented for application use, and will never be used
in such a situation in the compiler.

* eval.c (op_upenv): New static function.
(eval_init): Register sys:upenv special operator.

* compiler.tl (compiler compile): Implement compiled version
of sys:upenv.
---
 eval.c                       | 9 +++++++++
 share/txr/stdlib/compiler.tl | 1 +
 2 files changed, 10 insertions(+)

diff --git a/eval.c b/eval.c
index 5166f9e5..3acd7ac4 100644
--- a/eval.c
+++ b/eval.c
@@ -2803,6 +2803,14 @@ static val op_switch(val form, val env)
   return eval_progn(forms, env, forms);
 }
 
+static val op_upenv(val form, val env)
+{
+  val args = cdr(form);
+  val expr = pop(&args);
+  type_check(env, ENV);
+  return eval(expr, env->e.up_env, expr);
+}
+
 static val me_def_variable(val form, val menv)
 {
   val args = rest(form);
@@ -5940,6 +5948,7 @@ void eval_init(void)
   reg_op(with_dyn_rebinds_s, op_with_dyn_rebinds);
   reg_op(prof_s, op_prof);
   reg_op(switch_s, op_switch);
+  reg_op(intern(lit("upenv"), system_package), op_upenv);
 
   reg_mac(defvar_s, func_n2(me_def_variable));
   reg_mac(defparm_s, func_n2(me_def_variable));
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 06935a02..05ba8247 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -172,6 +172,7 @@
             (prog1 me.(comp-prog1 oreg env form))
             (sys:quasi me.(comp-quasi oreg env form))
             (dohash me.(compile oreg env (expand-dohash form)))
+            (sys:upenv me.(compile oreg env.up (cadr form)))
             (sys:dvbind me.(compile oreg env (caddr form)))
             (sys:with-dyn-rebinds me.(comp-progn oreg env (cddr form)))
             ((macrolet symacrolet macro-time)
-- 
cgit v1.2.3