diff options
| -rw-r--r-- | eval.c | 24 | ||||
| -rw-r--r-- | share/txr/stdlib/compiler.tl | 33 | ||||
| -rw-r--r-- | txr.1 | 38 |
3 files changed, 93 insertions, 2 deletions
@@ -202,6 +202,27 @@ val env_vbind(val env, val sym, val obj) } } +static val env_vbindings(val env) +{ + val self = lit("env-vbindings"); + type_check(self, env, ENV); + return env->e.vbindings; +} + +static val env_fbindings(val env) +{ + val self = lit("env-fbindings"); + type_check(self, env, ENV); + return env->e.fbindings; +} + +static val env_next(val env) +{ + val self = lit("env-next"); + type_check(self, env, ENV); + return env->e.up_env; +} + static void env_vb_to_fb(val env) { if (env) { @@ -6499,6 +6520,9 @@ void eval_init(void) reg_fun(intern(lit("make-env"), user_package), func_n3o(make_env_intrinsic, 0)); reg_fun(intern(lit("env-fbind"), user_package), func_n3(env_fbind)); reg_fun(intern(lit("env-vbind"), user_package), func_n3(env_vbind)); + reg_fun(intern(lit("env-vbindings"), user_package), func_n1(env_vbindings)); + reg_fun(intern(lit("env-fbindings"), user_package), func_n1(env_fbindings)); + reg_fun(intern(lit("env-next"), user_package), func_n1(env_next)); reg_fun(intern(lit("lexical-var-p"), user_package), func_n2(lexical_var_p)); reg_fun(intern(lit("lexical-fun-p"), user_package), func_n2(lexical_fun_p)); reg_fun(intern(lit("lexical-lisp1-binding"), user_package), diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index 51b0becd..2f27365d 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -1682,16 +1682,45 @@ (error "~s: compilation of ~s failed" 'compile-file (stream-get-prop in-stream :name))))))))) +(defun sys:env-to-let (env form) + (when env + (let ((vb (env-vbindings env)) + (fb (env-fbindings env)) + (up (env-next env))) + (when vb + (set form ^(let ,(mapcar (tb ((a . d)) ^(,a ',d)) vb) ,form))) + (when fb + (let (lbind fbind) + (each ((pair fb)) + (tree-bind (a . d) pair + (let* ((fun-p (interp-fun-p d)) + (fe (if fun-p (func-get-env d))) + (lb-p (and fe (eq fe env))) + (fb-p (and fe (eq fe up)))) + (cond + (lb-p (push ^(,a ,(func-get-form d)) lbind)) + (fb-p (push ^(,a ,(func-get-form d)) fbind)) + (t (push ^(,a ',d) fbind)))))) + (when lbind + (set form ^(sys:lbind ,(nreverse lbind) ,form))) + (when fbind + (set form ^(sys:fbind ,(nreverse fbind) ,form))))) + (if up + (set form (sys:env-to-let up form))))) + form) + (defun usr:compile (obj) (typecase obj (fun (tree-bind (indicator args . body) (func-get-form obj) - (let* ((form ^(lambda ,args ,*body)) + (let* ((form (sys:env-to-let (func-get-env obj) + ^(lambda ,args ,*body))) (vm-desc (compile-toplevel form))) (vm-execute-toplevel vm-desc)))) (t (condlet (((fun (symbol-function obj))) (tree-bind (indicator args . body) (func-get-form fun) - (let* ((form ^(lambda ,args ,*body)) + (let* ((form (sys:env-to-let (func-get-env fun) + ^(lambda ,args ,*body))) (vm-desc (compile-toplevel form)) (comp-fun (vm-execute-toplevel vm-desc))) (set (symbol-function obj) comp-fun)))) @@ -16435,6 +16435,44 @@ is specified as .codn nil , then the binding takes place in the global environment. +.coNP Functions @, env-vbindings @ env-fbindings and @ env-next +.synb +.mets (env-vbindings << env ) +.mets (env-fbindings << env ) +.mets (env-next << env ) +.syne +.desc +These function retrieve the components of +.metn env , +which must be an environment. The +.code env-vbindings +function retrieves the the association list representing variable +bindings. Similarly, the +.code env-fbindings +retrieves the association list of function bindings. +The +.code env-next +function retrieves the next environment, if +.meta env +has one, otherwise +.codn nil . + +If +.code e +is an environment constructed by the expression +.codn "(make-env v f n)" , +then +.code "(env-vbindings e)" +retrieves +.codn v , +.code "(env-fbindings e)" +retrieves +.code f +and +.code "(env-next e)" +returns +.codn n . + .SS* Global Environment .coNP Accessors @, symbol-function @ symbol-macro and @ symbol-value .synb |