list-build: rewrite methods for semantics & efficiency.

The list builder needlessly copies list structure. At
any given moment, the last piece of structure added to
the list can remain shared. We can leave the tail
pointing to that piece and copy it later in a nondestructive
operation.

Also, we would like (build (add 1) (pend 2)) to produce
(1 . 2) rather than an errror. The implementation gives this
to us in the same stroke.

* share/txr/stdlib/build.tl (list-builder :postinit): Just
initialize tail to be head, rather than eagerly chasing to the
last cons.
(list-builder add, list-builder pend, list-builder pend*,
list-builder ncon, list-builder ncon*): Rewrite.

1 files changed, 28 insertions, 10 deletions

diff --git a/share/txr/stdlib/build.tl b/share/txr/stdlib/build.tl
index 6fc3c83b..76d0fa2c 100644
--- a/share/txr/stdlib/build.tl
+++ b/share/txr/stdlib/build.tl
@@ -29,10 +29,14 @@
 
   (:postinit (bc)
     (set bc.head (cons nil bc.head)
-         bc.tail (last bc.head)))
+         bc.tail bc.head))
 
   (:method add (self . items)
-    (set self.tail (last (usr:rplacd self.tail (copy items)))))
+    (let ((tl self.tail))
+      (usr:rplacd tl (copy (cdr tl)))
+      (set tl (last tl))
+      (usr:rplacd tl items)
+      (set self.tail tl)))
 
   (:method add* (self . items)
     (let ((ic (copy items))
@@ -41,28 +45,42 @@
       (usr:rplacd h ic)))
 
   (:method pend (self . lists)
-    (while lists
-      (set self.tail (last (usr:rplacd self.tail (copy (car lists)))))
-      (set lists (cdr lists))))
+    (let ((tl self.tail))
+      (while lists
+        (usr:rplacd tl (copy (cdr tl)))
+        (set tl (last tl))
+        (usr:rplacd tl (car lists))
+        (set lists (cdr lists)))
+      (set self.tail tl)))
 
   (:method pend* (self . lists)
     (let* ((h self.head)
            (nh (cons nil nil))
            (tl nh))
       (while lists
-        (set tl (last (usr:rplacd tl (copy (car lists)))))
+        (usr:rplacd tl (copy tl))
+        (set tl (last tl))
+        (usr:rplacd tl (car lists))
         (set lists (cdr lists)))
+
+      (set tl (last tl))
       (usr:rplacd tl (cdr h))
       (set self.head nh)))
 
   (:method ncon (self . lists)
-    (set self.tail (last (usr:rplacd self.tail (nconc . lists)))))
+    (let ((tl self.tail))
+      (while lists
+        (set tl (last tl))
+        (usr:rplacd tl (car lists))
+        (set lists (cdr lists)))
+      (set self.tail tl)))
 
   (:method ncon* (self . lists)
-    (let ((h self.head))
-      (set (cdr h) (nconc (nconc . lists) (cdr h)))
+    (let* ((h self.head)
+           (pf (nconc (nconc . lists) (cdr h))))
+      (usr:rplacd h pf)
       (if (eq self.tail h)
-        (set self.tail (last h)))))
+        (set self.tail pf))))
 
   (:method get (self)
     (cdr self.head)))