[cclan-list] Circularity detection fix exposed a bug

[Richard M K. <kr...@pr...>]

Hi,

After the circularity detection patch applied in 1.125, test3 fails with
a spurious CIRCULAR-DEPENDENCY error.  I think the trouble is that
TRAVERSE fails to unvisit an operation/component pair at least for
feature-dependencies, and maybe elsewhere.  The patch below does the
un-visiting in an UNWIND-PROTECT cleanup, so should ensure that ASDF
always unvisit as desired.  All the tests pass with this change, but I'm
not really confident about anything TRAVERSE-related.  Does this look
like a reasonable thing to do?

Thanks,
Richard

--- asdf.lisp	6 Sep 2008 22:57:16 -0000	1.127
+++ asdf.lisp	9 Sep 2008 13:28:30 -0000
@@ -725,45 +725,47 @@
       (if (component-visiting-p operation c)
           (error 'circular-dependency :components (list c)))
       (setf (visiting-component operation c) t)
-      (loop for (required-op . deps) in (component-depends-on operation c)
-            do (do-dep required-op deps))
-      ;; constituent bits
-      (let ((module-ops
-             (when (typep c 'module)
-               (let ((at-least-one nil)
-                     (forced nil)
-                     (error nil))
-                 (loop for kid in (module-components c)
-                       do (handler-case
-                              (appendf forced (traverse operation kid ))
-                            (missing-dependency (condition)
-                              (if (eq (module-if-component-dep-fails c) :fail)
-                                  (error condition))
-                              (setf error condition))
-                            (:no-error (c)
-                              (declare (ignore c))
-                              (setf at-least-one t))))
-                 (when (and (eq (module-if-component-dep-fails c) :try-next)
-                            (not at-least-one))
-                   (error error))
-                 forced))))
-        ;; now the thing itself
-        (when (or forced module-ops
-                  (not (operation-done-p operation c))
-                  (let ((f (operation-forced (operation-ancestor operation))))
-                    (and f (or (not (consp f))
-                               (member (component-name
-                                        (operation-ancestor operation))
-                                       (mapcar #'coerce-name f)
-                                       :test #'string=)))))
-          (let ((do-first (cdr (assoc (class-name (class-of operation))
-                                      (slot-value c 'do-first)))))
-            (loop for (required-op . deps) in do-first
-                  do (do-dep required-op deps)))
-          (setf forced (append (delete 'pruned-op forced :key #'car)
-                               (delete 'pruned-op module-ops :key #'car)
-                               (list (cons operation c))))))
-      (setf (visiting-component operation c) nil)
+      (unwind-protect
+          (progn
+            (loop for (required-op . deps) in (component-depends-on operation c)
+                  do (do-dep required-op deps))
+            ;; constituent bits
+            (let ((module-ops
+                   (when (typep c 'module)
+                     (let ((at-least-one nil)
+                           (forced nil)
+                           (error nil))
+                       (loop for kid in (module-components c)
+                             do (handler-case
+                                    (appendf forced (traverse operation kid ))
+                                  (missing-dependency (condition)
+                                    (if (eq (module-if-component-dep-fails c) :fail)
+                                        (error condition))
+                                    (setf error condition))
+                                  (:no-error (c)
+                                    (declare (ignore c))
+                                    (setf at-least-one t))))
+                       (when (and (eq (module-if-component-dep-fails c) :try-next)
+                                  (not at-least-one))
+                         (error error))
+                       forced))))
+              ;; now the thing itself
+              (when (or forced module-ops
+                        (not (operation-done-p operation c))
+                        (let ((f (operation-forced (operation-ancestor operation))))
+                          (and f (or (not (consp f))
+                                     (member (component-name
+                                              (operation-ancestor operation))
+                                             (mapcar #'coerce-name f)
+                                             :test #'string=)))))
+                (let ((do-first (cdr (assoc (class-name (class-of operation))
+                                            (slot-value c 'do-first)))))
+                  (loop for (required-op . deps) in do-first
+                        do (do-dep required-op deps)))
+                (setf forced (append (delete 'pruned-op forced :key #'car)
+                                     (delete 'pruned-op module-ops :key #'car)
+                                     (list (cons operation c)))))))
+        (setf (visiting-component operation c) nil))
       (visit-component operation c (and forced t))
       forced)))