list-builder: bugfix: broken self-appending.

The list builder is failing on the documented example

  (build
    (add 1 2)
    (pend (get))
    (pend (get)))
  -> (1 2 1 2 1 2 1 2)

wrongly constructing an infinite list.

* share/txr/stdlib/build.tl (list-builder pend): When
destructively appending the next argument, check whether
the current tail is a tail of that object. If so, copy
the object to prevent a cycle from forming.
(list-builder pend*): When appending the old head to the
catenated list, do the tail check and copy the object if
necessary to prevent the creation of a cycle.

1 files changed, 7 insertions, 4 deletions

diff --git a/share/txr/stdlib/build.tl b/share/txr/stdlib/build.tl
index 32df083d..a5960578 100644
--- a/share/txr/stdlib/build.tl
+++ b/share/txr/stdlib/build.tl
@@ -51,22 +51,25 @@
       (while lists
         (usr:rplacd tl (copy (cdr tl)))
         (set tl (last tl))
-        (usr:rplacd tl (car lists))
+        (let ((nx (car lists)))
+          (usr:rplacd tl (if (tailp tl nx)
+                           (copy nx)
+                           nx)))
         (set lists (cdr lists)))
       (set self.tail tl))
     nil)
 
   (:method pend* (self . lists)
-    (let* ((h self.head)
+    (let* ((h (cdr self.head))
            (nh (cons nil nil))
            (tl nh))
       (while lists
-        (usr:rplacd tl (copy tl))
+        (usr:rplacd tl (copy (cdr tl)))
         (set tl (last tl))
         (usr:rplacd tl (car lists))
         (set lists (cdr lists)))
       (set tl (last tl))
-      (usr:rplacd tl (cdr h))
+      (usr:rplacd tl (if (tailp tl h) (copy h) h))
       (set self.head nh))
     nil)