[alexandria.git] updated branch master: cd15854 fix edge-case in CIRCULAR-TREE-P

[Nikodemus Siivola]

The branch master has been updated:
       via  cd158549ef56f10ef660f22cf4f9ddd96f0693c3 (commit)
      from  3eacfac87b27654f7ca9eeaf1ce40344b8136b03 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit cd158549ef56f10ef660f22cf4f9ddd96f0693c3
Author: Anton Kovalenko <anton at sw4me.com>
Date:   Sun Oct 30 00:33:42 2011 +0300

    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).

-----------------------------------------------------------------------

Summary of changes:
 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))
-- 
Alexandria hooks/post-receive