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.

1 files 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)