From db1fc32ebe29de61b0432a72385516a186f62a87 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Fri, 4 Nov 2016 21:59:46 -0700 Subject: Fix broken tracking of place expansion origins. This change actually achieves the original intent that forms generated by place expansion register the place as their macro-expansion origin, enabling clearer diagnostics when things go wrong in that generated code. * share/txr/stdlib/place.tl (sys:cp-origin): Drop the syms argument; it's useless because we want to walk over the fully expanded to-tree in which those syms (denoting the names of local macros) will no longer appear. Now instead we find any conses in to-tree which already have macro ancestors. We trace the ancestor chain to the end and install the place form as the grand-ancestor, to express that all the expansion ultimately is derived from the place that is being manipulated. (call-update-expander, call-clobber-expander, call-delete-expander): After calling the expander, fully expand whatever it returns in the given environment. Then, propagate place as the macro origin throughout the forms contained in the expansion before returning it. --- share/txr/stdlib/place.tl | 36 ++++++++++++++++++++++-------------- 1 file changed, 22 insertions(+), 14 deletions(-) diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl index 7112f0ae..48e0182e 100644 --- a/share/txr/stdlib/place.tl +++ b/share/txr/stdlib/place.tl @@ -162,35 +162,43 @@ (return place)) (sys:setq unex-place place)))) - (defun sys:cp-origin (to-tree from-form syms : circ-check) + (defun sys:cp-origin (to-tree from-form : circ-check) (unless (memq to-tree circ-check) (tree-case to-tree - ((a . d) (when (memq a syms) - (sys:set-macro-ancestor to-tree from-form)) - (sys:cp-origin a from-form syms (cons to-tree circ-check)) - (sys:cp-origin d from-form syms (cons to-tree circ-check))))) + ((a . d) (whenlet (next-orig + (orig (macro-ancestor to-tree))) + (while (and (neq orig from-form) + (sys:setq next-orig (macro-ancestor orig))) + (sys:setq orig next-orig)) + (unless (eq orig from-form) + (sys:set-macro-ancestor orig from-form))) + (sys:cp-origin a from-form (cons to-tree circ-check)) + (sys:cp-origin d from-form (cons to-tree circ-check))))) to-tree) (defun call-update-expander (getter setter unex-place env body) (let* ((place (sys:pl-expand unex-place env)) (expander (get-update-expander place)) - (sys:*pl-env* env)) - (sys:cp-origin [expander getter setter place body] - place (list setter getter)))) + (sys:*pl-env* env) + (expansion [expander getter setter place body]) + (expansion-ex (sys:expand expansion env))) + (sys:cp-origin expansion-ex place))) (defun call-clobber-expander (ssetter unex-place env body) (let* ((place (sys:pl-expand unex-place env)) (expander (get-clobber-expander place)) - (sys:*pl-env* env)) - (sys:cp-origin [expander ssetter place body] - place (list ssetter)))) + (sys:*pl-env* env) + (expansion [expander ssetter place body]) + (expansion-ex (sys:expand expansion env))) + (sys:cp-origin expansion-ex place))) (defun call-delete-expander (deleter unex-place env body) (let* ((place (sys:pl-expand unex-place env)) (expander (get-delete-expander place)) - (sys:*pl-env* env)) - (sys:cp-origin [expander deleter place body] - place (list deleter))))) + (sys:*pl-env* env) + (expansion [expander deleter place body]) + (expansion-ex (sys:expand expansion env))) + (sys:cp-origin expansion-ex place)))) (defmacro with-update-expander ((getter setter) unex-place env body) ^(with-gensyms (,getter ,setter) -- cgit v1.2.3