From cd158549ef56f10ef660f22cf4f9ddd96f0693c3 Mon Sep 17 00:00:00 2001
From: Anton Kovalenko <anton@sw4me.com>
Date: Sun, 30 Oct 2011 00:33:42 +0300
Subject: [PATCH] fix edge-case in CIRCULAR-TREE-P

  CIRCULAR-TREE-P had an unfortunate corner case, causing it to overflow
  the stack (seen and repoted at #lisp for '#1=(#1#).)

  The problem is caused by the end-test (of the outer DO) being run before the
  body has a first chance to check for (member slow seen).
---
 lists.lisp | 16 +++++++++-------
 tests.lisp |  4 ++++
 2 files changed, 13 insertions(+), 7 deletions(-)

diff --git a/lists.lisp b/lists.lisp
index ffe418a..6367bc7 100644
--- a/lists.lisp
+++ b/lists.lisp
@@ -151,14 +151,16 @@ destructively modifying it and saves back the result into the place.")
              (and (consp object)
                   (do ((fast (cons (car object) (cdr object)) (cddr fast))
                        (slow object (cdr slow)))
-                      ((or (not (consp fast)) (not (consp (cdr slow))))
-                       (do ((tail object (cdr tail)))
-                           ((not (consp tail))
-                            nil)
-                         (let ((elt (car tail)))
-                           (circularp elt (cons object seen)))))
+                      (nil)
                     (when (or (eq fast slow) (member slow seen))
-                      (return-from circular-tree-p t))))))
+                      (return-from circular-tree-p t))
+                    (when (or (not (consp fast)) (not (consp (cdr slow))))
+                      (return
+                        (do ((tail object (cdr tail)))
+                            ((not (consp tail))
+                             nil)
+                          (let ((elt (car tail)))
+                            (circularp elt (cons object seen))))))))))
     (circularp object nil)))
 
 (defun proper-list-p (object)
diff --git a/tests.lisp b/tests.lisp
index b9e2277..ef7d19d 100644
--- a/tests.lisp
+++ b/tests.lisp
@@ -606,6 +606,10 @@
             (circular-tree-p quite-dotted)))
   (t t t t t t nil nil))
 
+(deftest circular-tree-p.2
+    (alexandria:circular-tree-p '#1=(#1#))
+  t)
+
 (deftest proper-list-p.1
     (let ((l1 (list 1))
           (l2 (list 1 2))
-- 
GitLab