summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2019-08-28 06:59:46 -0700
committerKaz Kylheku <kaz@kylheku.com>2019-08-28 06:59:46 -0700
commit5dfae394410270cb884f32d4f8591a60e1e4a76c (patch)
tree7582ca1f78e676e5781330121f4000c5c75eea98
parentb4360fddf3f7368d618b3a706397c2b437ba074f (diff)
downloadtxr-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.tl150
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