diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2019-08-28 06:59:46 -0700 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2019-08-28 06:59:46 -0700 |
commit | 5dfae394410270cb884f32d4f8591a60e1e4a76c (patch) | |
tree | 7582ca1f78e676e5781330121f4000c5c75eea98 | |
parent | b4360fddf3f7368d618b3a706397c2b437ba074f (diff) | |
download | txr-5dfae394410270cb884f32d4f8591a60e1e4a76c.tar.gz txr-5dfae394410270cb884f32d4f8591a60e1e4a76c.tar.bz2 txr-5dfae394410270cb884f32d4f8591a60e1e4a76c.zip |
compiler: bugfix: incorrect scoping in macro param binding.
The destructuring binder binds all of the variables in the
template to nil values and then assigns to them as it walks
the object that is being destructured. Unfortunately, this
results in incorrect treatment of init-forms, which are
evaluated in the wrong scope. They are actually evaluated in
completely the wrong scope due to the use of up:env, but the
problem can't be fixed by removing up:env.
The approach here is to generate a big let* construct that
binds the variables in sequence, rather than assigning to
them.
* share/txr/stdlib/compiler.tl (expand-bind-mac-params):
The basic structure of the code remains the same, but the
details are rewritten. Instead of emitting a body of forms, we
emit let* bindings. Because some of the logic requires
imperative statements, like stepping pointers through the
destructured object, these are mixed into the variable
initializations via progn. The local functions emit-stmt and
emit-var provide the interface for doing this. There is a bit
of trickery in the situation that an optional parameter also
has the presence-indicator variable. We must bind the
parameter in an environment in which that presence-indicator
variable is not yet visible. This is achieved by binding the
variable to a nil value, and then binding the presence
indicator to an expression which sets the variable's value as
a side effect, and yields a Boolean value that initializes the
indicator.
-rw-r--r-- | share/txr/stdlib/compiler.tl | 150 |
1 files changed, 85 insertions, 65 deletions
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl index a4c985e8..be69bb67 100644 --- a/share/txr/stdlib/compiler.tl +++ b/share/txr/stdlib/compiler.tl @@ -1369,86 +1369,106 @@ (defun expand-bind-mac-params (ctx-form err-form params menv-var obj-var strict err-block body) - (let (vars gen-stk (plen (if (and strict (neq strict t)) (gensym)))) + (let (gen-stk stmt vars (plen (if (and strict (neq strict t)) (gensym)))) (labels ((get-gen () (or (pop gen-stk) (gensym))) (put-gen (g) (push g gen-stk)) - (expand-rec (par-syntax obj-var) - (let* ((pars (new (mac-param-parser par-syntax ctx-form))) - (curs (get-gen))) - (unwind-protect - ^(,*(when plen - ^((set ,plen (if (consp ,obj-var) - (len ,obj-var) 0)))) - ,*(cond + (expand-rec (par-syntax obj-var check-var) + (labels ((emit-stmt (form) + (when form + (if check-var + (push ^(when ,check-var ,form) stmt) + (push form stmt)))) + (emit-var (sym init-form) + (push (if stmt + (prog1 + ^(,sym (progn ,*(nreverse stmt) + ,(if check-var + ^(when ,check-var ,init-form) + init-form))) + (set stmt nil)) + ^(,sym ,(if check-var + ^(when ,check-var ,init-form) + init-form))) + vars))) + (let* ((pars (new (mac-param-parser par-syntax ctx-form))) + (curs (get-gen))) + (unwind-protect + (progn + (when plen + (emit-var plen ^(if (consp ,obj-var) + (len ,obj-var) 0))) + (cond ((eq strict t) - ^((sys:bind-mac-check ,err-form ',par-syntax - ,obj-var ,pars.nreq - ,(unless pars.rest pars.nfix)))) - ((null strict) nil) + (emit-stmt + ^(sys:bind-mac-check ,err-form ',par-syntax + ,obj-var ,pars.nreq + ,(unless pars.rest + pars.nfix)))) + ((null strict)) ((symbolp strict) - (if pars.rest - ^((unless (<= ,pars.nreq ,plen) - (return-from ,err-block ',strict))) - ^((unless (<= ,pars.nreq ,plen ,pars.nfix) - (return-from ,err-block ',strict)))))) - ,*(append-each ((k pars.key)) + (emit-stmt + (if pars.rest + ^(unless (<= ,pars.nreq ,plen) + (return-from ,err-block ',strict)) + ^(unless (<= ,pars.nreq ,plen ,pars.nfix) + (return-from ,err-block ',strict)))))) + (each ((k pars.key)) (tree-bind (key . sym) k - (push sym vars) (caseq key - (:whole ^((set ,sym ,obj-var))) - (:form ^((set ,sym ,ctx-form))) - (:env ^((set ,sym ,menv-var)))))) - ,*(append-each ((p pars.req)) + (:whole (emit-var sym obj-var)) + (:form (emit-var sym ctx-form)) + (:env (emit-var sym menv-var))))) + (each ((p pars.req)) (cond ((listp p) - ^((set ,curs (car ,obj-var)) - (set ,obj-var (cdr ,obj-var)) - ,*(expand-rec p curs))) + (emit-stmt ^(set ,curs (car ,obj-var))) + (emit-stmt ^(set ,obj-var (cdr ,obj-var))) + (expand-rec p curs check-var)) (t - (push p vars) - ^((set ,p (car ,obj-var)) - (set ,obj-var (cdr ,obj-var)))))) - ,*(append-each ((o pars.opt)) + (emit-var p ^(car ,obj-var)) + (emit-stmt ^(set ,obj-var (cdr ,obj-var)))))) + (each ((o pars.opt)) (tree-bind (p : init-form pres-p) o (cond ((listp p) - (when pres-p - (push pres-p vars)) - ^((set ,curs (or (car ,obj-var) - (sys:upenv ,init-form))) - (cond - (,obj-var - (set ,curs (car ,obj-var)) - (set ,obj-var (cdr ,obj-var)) - ,*(if pres-p - ^((set ,pres-p t)))) - (t - (set ,curs (sys:upenv ,init-form)))) - (when ,curs - ,*(expand-rec p curs)))) + (let ((stmt ^(cond + (,obj-var + (set ,curs (car ,obj-var)) + (set ,obj-var (cdr ,obj-var)) + ,(if pres-p t)) + (t + (set ,curs ,init-form) + ,(if pres-p nil))))) + (if pres-p + (emit-var pres-p stmt) + (emit-stmt stmt)) + (let ((cv (gensym))) + (emit-var cv curs) + (expand-rec p curs cv)))) (t - (push p vars) - (when pres-p - (push pres-p vars)) - ^((cond - (,obj-var - (set ,p (car ,obj-var)) - (set ,obj-var (cdr ,obj-var)) - ,*(if pres-p - ^((set ,pres-p t)))) - (t - ,*(if init-form - ^((set ,p (sys:upenv ,init-form))))))))))) - ,*(when pars.rest - (push pars.rest vars) - ^((set ,pars.rest ,obj-var)))) - (put-gen curs))))) - (let ((bind-code (expand-rec params obj-var))) - ^(let (,*(nreverse vars) ,*(if plen ^(,plen)) ,*gen-stk) - ,*bind-code - ,*body))))) + (let ((stmt ^(cond + (,obj-var + (set ,p (car ,obj-var)) + (set ,obj-var (cdr ,obj-var)) + ,(if pres-p t)) + (t + ,(if init-form + ^(set ,p ,init-form)) + ,(if pres-p nil))))) + (emit-var p nil) + (if pres-p + (emit-var pres-p stmt) + (emit-stmt stmt))))))) + (when pars.rest + (emit-var pars.rest obj-var))) + (put-gen curs)))))) + (expand-rec params obj-var nil) + (when stmt + (push ^(,(gensym) (progn ,*(nreverse stmt))) vars)) + ^(let* (,*(if plen ^(,plen)) ,*gen-stk ,*(nreverse vars)) + ,*body)))) (defun expand-defvarl (form) (mac-param-bind form (op sym : value) form |