From 66ae458067d7b9e8490df376bfe3281de68ef768 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Wed, 19 Oct 2016 06:35:55 -0700 Subject: Cycle detection in sys:cp-origin. Tree-walking code in the place expander runs into trouble if the expression contains cycles. Test case: (defparm a '(#1=(a . #1#))). * share/txr/stdlib/place.tl (sys:cp-origin): Take list of symbols as a single argument instead of trailing arguments. Support an optional argument that gives serves as a cycle-detecting stack. Bail if a cycle is detected. (call-udpate-expander, call-clobber-expander, call-delete-expander): Update sys:cp-origin calls to follow interface change. --- share/txr/stdlib/place.tl | 22 +++++++++++++--------- 1 file changed, 13 insertions(+), 9 deletions(-) (limited to 'share') diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl index e3ba6c0f..acb17886 100644 --- a/share/txr/stdlib/place.tl +++ b/share/txr/stdlib/place.tl @@ -160,31 +160,35 @@ (return place)) (sys:setq unex-place place)))) - (defun sys:cp-origin (to-tree from-form . syms) - (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) - (sys:cp-origin d from-form . syms))) + (defun sys:cp-origin (to-tree from-form syms : 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))))) 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 setter getter))) + (sys:cp-origin [expander getter setter place body] + place (list setter getter)))) (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 ssetter))) + (sys:cp-origin [expander ssetter place body] + place (list ssetter)))) (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 deleter)))) + (sys:cp-origin [expander deleter place body] + place (list deleter))))) (defmacro with-update-expander ((getter setter) unex-place env body) ^(with-gensyms (,getter ,setter) -- cgit v1.2.3