Replace sys:cp-origin with smarter function.

sys:cp-origin blindly propagates macro origin into a
tree structure, and has to perform a complicated circularity
check to avoid introducing cycles

We replace it with a new function which looks only for
invocations of the local setter, getter or deleter macros
within the tree structure and sets the macro origin only
into those forms.

* share/txr/stdlib/place.tl (sys:cp-origin): Function removed.
(sys:propagate-ancestor): New function.
(call-update-expander, call-clobber-expander,
call-delete-expander): Use new function.

1 files changed, 10 insertions, 17 deletions

diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index ffe5aa91..e3156d70 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -155,20 +155,13 @@
   ^(let ,(zip syms (repeat '((gensym)))) ,*body))
 
 (macro-time
-  (defun sys:cp-origin (to-tree from-form : circ-check)
-    (unless (memq to-tree circ-check)
-      (tree-case to-tree
-        ((a . d) (whenlet ((next-orig nil)
-                           (visited-stack (list from-form))
-                           (orig (macro-ancestor to-tree)))
-                   (while (and (not (memq orig visited-stack))
-                               (sys:setq next-orig (macro-ancestor orig)))
-                     (sys:setq visited-stack (cons next-orig visited-stack))
-                     (sys:setq orig next-orig))
-                   (unless (memq orig visited-stack)
-                     (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)))))
+  (defun sys:propagate-ancestor (to-tree from-form . syms)
+    (tree-case to-tree
+      ((a . d)
+       (when (memq a syms)
+         (sys:set-macro-ancestor to-tree from-form))
+       (sys:propagate-ancestor a from-form . syms)
+       (sys:propagate-ancestor d from-form . syms)))
     to-tree)
 
   (defun call-update-expander (getter setter unex-place env body)
@@ -177,7 +170,7 @@
            (sys:*pl-env* env)
            (expansion [expander getter setter place body])
            (expansion-ex (sys:expand expansion env)))
-      (sys:cp-origin expansion-ex place)))
+      (sys:propagate-ancestor expansion-ex place getter setter)))
 
   (defun call-clobber-expander (ssetter unex-place env body)
     (let* ((place (sys:pl-expand unex-place env))
@@ -185,7 +178,7 @@
            (sys:*pl-env* env)
            (expansion [expander ssetter place body])
            (expansion-ex (sys:expand expansion env)))
-      (sys:cp-origin expansion-ex place)))
+      (sys:propagate-ancestor expansion-ex place ssetter)))
 
   (defun call-delete-expander (deleter unex-place env body)
     (let* ((place (sys:pl-expand unex-place env))
@@ -193,7 +186,7 @@
            (sys:*pl-env* env)
            (expansion [expander deleter place body])
            (expansion-ex (sys:expand expansion env)))
-      (sys:cp-origin expansion-ex place))))
+      (sys:propagate-ancestor expansion-ex place deleter))))
 
 (defmacro with-update-expander ((getter setter) unex-place env body)
   ^(with-gensyms (,getter ,setter)