diff options
| -rw-r--r-- | eval.c | 67 | ||||
| -rw-r--r-- | stdlib/compiler.tl | 27 | ||||
| -rw-r--r-- | stdlib/doc-syms.tl | 1 | ||||
| -rw-r--r-- | tests/019/progv.tl | 29 | ||||
| -rw-r--r-- | txr.1 | 62 |
5 files changed, 185 insertions, 1 deletions
@@ -74,7 +74,7 @@ val op_table, pm_table; val dyn_env; val eval_error_s, case_error_s; -val dwim_s, progn_s, prog1_s, prog2_s, sys_blk_s; +val dwim_s, progn_s, prog1_s, prog2_s, progv_s, sys_blk_s; val let_s, let_star_s, lambda_s, call_s, dvbind_s; val sys_catch_s, handler_bind_s, cond_s, if_s, iflet_s, when_s, usr_var_s; val defvar_s, defvarl_s, defparm_s, defparml_s, defun_s, defmacro_s, macro_s; @@ -1900,6 +1900,41 @@ static val op_prog1(val form, val env) return eval_prog1(rest(form), env, form); } +static val op_progv(val form, val env) +{ + val args = cdr(form); + val vars_expr = pop(&args); + val vals_expr = pop(&args); + val body = args; + val vars = eval(vars_expr, env, form); + val vals = eval(vals_expr, env, form); + val saved_de = dyn_env; + val new_env = dyn_env = make_env(nil, nil, saved_de); + val ret, vari, vali; + + for (vari = vars, vali = vals; vari && vali; + vari = cdr(vari), vali = cdr(vali)) + { + val var = car(vari); + if (!bindable(var)) + not_bindable_error(form, var); + env_vbind(new_env, var, car(vali)); + } + + for (; vari; vari = cdr(vari)) { + val var = car(vari); + if (!bindable(var)) + not_bindable_error(form, var); + env_vbind(new_env, var, unbound_s); + } + + ret = eval_progn(body, env, form); + + dyn_env = saved_de; + + return ret; +} + static val op_let(val form, val env) { val let = first(form); @@ -5226,6 +5261,17 @@ again: return car(args_ex); } return expand(first(args), menv); + } else if (sym == progv_s) { + val body = (syn_check(form, sym, cddr, 0), cdddr(form)); + val vars = cadr(form); + val vals = caddr(form); + val vars_ex = expand(vars, menv); + val vals_ex = expand(vals, menv); + val body_ex = expand_forms(body, menv); + + if (vars_ex == vars && vals_ex == vals && body_ex == body) + return form; + return rlcp(cons(sym, cons(vars_ex, cons(vals_ex, body_ex))), form); } else if (sym == sys_lisp1_value_s) { return expand_lisp1_value(form, menv); } else if (sym == sys_lisp1_setq_s) { @@ -5859,6 +5905,22 @@ static val set_symbol_value(val sym, val value) return value; } +static val rt_progv(val syms, val values) +{ + val env = dyn_env; + + for (; syms; syms = cdr(syms), values = cdr(values)) + { + val sym = car(syms); + val value = if3(values, car(values), unbound_s); + if (!bindable(sym)) + uw_throwf(error_s, lit("progv: ~s isn't a bindable symbol"), sym, nao); + env_vbind(env, sym, value); + } + + return nil; +} + static val symbol_function(val sym) { uses_or2; @@ -6829,6 +6891,7 @@ void eval_init(void) progn_s = intern(lit("progn"), user_package); prog1_s = intern(lit("prog1"), user_package); prog2_s = intern(lit("prog2"), user_package); + progv_s = intern(lit("progv"), user_package); sys_blk_s = intern(lit("blk"), system_package); let_s = intern(lit("let"), user_package); let_star_s = intern(lit("let*"), user_package); @@ -6965,6 +7028,7 @@ void eval_init(void) reg_op(sys_splice_s, op_unquote_error); reg_op(progn_s, op_progn); reg_op(prog1_s, op_prog1); + reg_op(progv_s, op_progv); reg_op(let_s, op_let); reg_op(each_op_s, op_each); reg_op(let_star_s, op_let); @@ -7680,6 +7744,7 @@ void eval_init(void) reg_fun(intern(lit("rt-defvarl"), system_package), func_n1(rt_defvarl)); reg_fun(intern(lit("rt-defv"), system_package), func_n1(rt_defv)); + reg_fun(intern(lit("rt-progv"), system_package), func_n2(rt_progv)); reg_fun(intern(lit("rt-defun"), system_package), func_n2(rt_defun)); reg_fun(intern(lit("rt-defmacro"), system_package), func_n3(rt_defmacro)); reg_fun(intern(lit("rt-defsymacro"), system_package), func_n2(rt_defsymacro)); diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl index cdbd3a3f..cc4eef7b 100644 --- a/stdlib/compiler.tl +++ b/stdlib/compiler.tl @@ -531,6 +531,7 @@ (and me.(compile oreg env (expand-and form))) (or me.(comp-or oreg env form)) (prog1 me.(comp-prog1 oreg env form)) + (progv me.(comp-progv oreg env form)) (sys:quasi me.(comp-quasi oreg env form)) (dohash me.(compile oreg env (expand-dohash form))) (tree-bind me.(comp-tree-bind oreg env form)) @@ -1324,6 +1325,32 @@ ((t fi) me.(compile oreg env fi)) ((t) me.(compile oreg env nil)))) +(defmeth compiler comp-progv (me oreg env form) + (tree-case form + ((t syms vals) + me.(comp-progn oreg env ^(progn ,syms ,vals nil))) + ((t syms vals . body) + (let* ((denv (new env up env co me)) + (sreg me.(alloc-treg)) + (vreg me.(alloc-treg)) + (sfrag me.(compile sreg env syms)) + (vfrag me.(compile vreg env vals)) + (bfrag me.(comp-progn oreg denv body))) + me.(free-treg sreg) + me.(free-treg vreg) + (new (frag bfrag.oreg + (append sfrag.code + vfrag.code + ^((dframe ,denv.lev 0) + (gcall ,oreg + ,me.(get-sidx 'sys:rt-progv) + ,sfrag.oreg + ,vfrag.oreg)) + bfrag.code + '((end nil))) + (uni sfrag.fvars (uni vfrag.fvars bfrag.fvars)) + (uni sfrag.ffuns (uni vfrag.ffuns bfrag.ffuns)))))))) + (defmeth compiler comp-quasi (me oreg env form) (let ((qexp (expand-quasi form))) me.(compile oreg env (expand qexp)))) diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl index f3e6e9b7..8dbadf88 100644 --- a/stdlib/doc-syms.tl +++ b/stdlib/doc-syms.tl @@ -1504,6 +1504,7 @@ ("prog1" "N-03F7A8B8") ("prog2" "N-03A0E48C") ("progn" "N-03F7A8B8") + ("progv" "N-033405DF") ("promisep" "N-00C7553F") ("prop" "N-01C6D406") ("proper-list-p" "N-03F70343") diff --git a/tests/019/progv.tl b/tests/019/progv.tl new file mode 100644 index 00000000..7ab3aafe --- /dev/null +++ b/tests/019/progv.tl @@ -0,0 +1,29 @@ +(load "../common") + +(defvar a 42) +(defvar b 73) + +(mtest + (progv '(a) '(1) a) 1 + (progv '(a b) '(1 2) (cons a b)) (1 . 2) + (progv '(x) '(1) (let ((x 4)) (symbol-value 'x))) 1) + +(let ((n (list 'a 'b)) + (v (list 1 2))) + (mtest + (progv n v (cons a b)) (1 . 2))) + +(defvarl x) + +(let ((x 'lexical) + (vars (list 'x)) + (vals (list 'dynamic))) + (test + (progv vars vals (list x (symbol-value 'x))) + (lexical dynamic))) + +(compile-only + (eval-only + (with-compile-opts (nil unused) + (compile-file (base-name *load-path*) "temp.tlo")) + (remove-path "temp.tlo"))) @@ -15060,6 +15060,68 @@ closures, but are captured in delimited continuations. (let (:a nil)) -> error, :a and nil can't be used as variables .brev +.coNP Operator @ progv +.synb +.mets (progv < symbols-expr < values-expr << body-form *) +.syne +.desc +The +.code progv +operator binds dynamic variables, and evaluates the +.metn body-form s +in the dynamic scope of those bindings. The bindings are removed +when the form terminates. The result value is that of the +last +.meta body-form +or else +.code nil +if there are no forms. + +The +.meta symbols-expr +and +.meta values-expr +are expressions which are evaluated. Their values are expected +to be lists, of bindable symbols and arbitrary values, respectively. +The symbols coming from one list are bound to the values coming +from the other list. + +If there are more symbols than values, then the extra symbols +will appear unbound, as if they were first bound and then hidden +using the +.code makunbound +function. + +If there are more values than symbols, the extra values are ignored. + +Note that dynamic binding takes place for the symbols even if they +have not been introduced as special variables via +.code defvar +or +.codn defparm . +However, if those symbols appear as expressions denoting variables inside the +.metn body-form s, +they will not necessarily be treated as dynamic variables. +If they have lexical definitions in scope, those will be referenced. +Furthermore, the compiler treats undefined variables as global +references, and not dynamic. + +.TP* Examples: + +.verb + + (progv '(a b) '(1 2) (cons a b)) -> (1 . 2) + + (progv '(x) '(1) (let ((x 4)) (symbol-value 'x))) -> 1 + + (let ((x 'lexical) + (vars (list 'x)) + (vals (list 'dynamic))) + (progv vars vals (list x (symbol-value 'x)))) + + --> (lexical dynamic) +.brev + .SS* Functions .coNP Operator @ defun .synb |