From b2739251281d7f6ef4d30164101bdf2a8d537a72 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Mon, 9 Sep 2019 06:46:06 -0700
Subject: list-builder: rewrite of basic methods.

Rewriting be addition, pending and nconcing methods of
list-builder to avoid loops and rely on lower list processing
functions. This cleans up the semantics and error messages.

Some examples of behavioral changes:

(build (pend "abc") (add #\d)) now returns "abcd",
consistent with (append "abc" '(#\d)).
Previously it returned '(#\d).

(build (add 1) (pend 2) (pend 3)) now produces a "cannot
append to 2" error.
Previously it produced "copy: cannot copy object of type fixnum".

* share/txr/stdlib/build.tl (list-builder add): Don't use
copy-list; rather the idiom for copying a sequence in
preparation for appending to it is (append x nil). This will
blow up nicely if x is an atom other than nil. We use
this trick twice.
(list-builder add*): Simplify with append.
(pend, pend*, ncon): Rewrite.
(ncon*): Use nconc once on a combined argument list: this is
borrowed from the rewritten pend*.

* txr.1: Documentation updated with clarifications,
particularly in the area of the requirements regarding
destructive manipulation and substructure sharing.
---
 share/txr/stdlib/build.tl | 67 ++++++++++++++++++++---------------------------
 1 file changed, 29 insertions(+), 38 deletions(-)

(limited to 'share')

diff --git a/share/txr/stdlib/build.tl b/share/txr/stdlib/build.tl
index 41826255..2c9f97ca 100644
--- a/share/txr/stdlib/build.tl
+++ b/share/txr/stdlib/build.tl
@@ -32,59 +32,50 @@
          bc.tail bc.head))
 
   (:method add (self . items)
-    (let ((tl self.tail))
-      (usr:rplacd tl (copy-list (cdr tl)))
-      (set tl (last tl))
-      (usr:rplacd tl items)
+    (let ((st self.tail))
+      (rplacd st (append (cdr st) nil)))
+    (let ((tl (last self.tail)))
+      (usr:rplacd tl (append (cdr tl) items))
       (set self.tail tl))
     nil)
 
   (:method add* (self . items)
-    (let ((ic (copy-list items))
-          (h self.head))
-      (usr:rplacd (last ic) (cdr h))
-      (usr:rplacd h ic))
+    (let ((h self.head))
+      (usr:rplacd h (append items (cdr h))))
     nil)
 
   (:method pend (self . lists)
-    (let ((tl self.tail))
-      (while lists
-        (usr:rplacd tl (copy-list (cdr tl)))
-        (set tl (last tl))
-        (let ((nx (car lists)))
-          (usr:rplacd tl (if (tailp tl nx)
-                           (copy-list nx)
-                           nx)))
-        (set lists (cdr lists)))
-      (set self.tail tl))
-    nil)
+    (when lists
+      (let ((st self.tail))
+        (rplacd st (append (cdr st) nil)))
+      (let* ((tl (last self.tail))
+             (cp (let ((ll (car (last lists))))
+                   (if (consp ll)
+                     (let ((lt (last ll)))
+                       (eq tl lt)))))
+             (nl [apply append lists]))
+        (usr:rplacd tl (append (cdr tl) (if cp (copy-list nl) nl)))
+        (set self.tail tl))
+      nil))
 
   (:method pend* (self . lists)
-    (let* ((h (cdr self.head))
-           (nh (cons nil nil))
-           (tl nh))
-      (while lists
-        (usr:rplacd tl (copy-list (cdr tl)))
-        (set tl (last tl))
-        (usr:rplacd tl (car lists))
-        (set lists (cdr lists)))
-      (set tl (last tl))
-      (usr:rplacd tl (if (tailp tl h) (copy-list h) h))
-      (set self.head nh))
+    (let* ((h self.head)
+           (pf [apply apply (append lists (list (cdr h)))]))
+      (usr:rplacd h pf)
+      (set self.tail self.head))
     nil)
 
   (:method ncon (self . lists)
-    (let ((tl self.tail))
-      (while lists
-        (set tl (last tl))
-        (usr:rplacd tl (car lists))
-        (set lists (cdr lists)))
-      (set self.tail tl))
-    nil)
+    (when lists
+      (let* ((tl (last self.tail))
+             (nl [apply nconc lists]))
+        (usr:rplacd tl (nconc (cdr tl) nl))
+        (set self.tail tl))
+      nil))
 
   (:method ncon* (self . lists)
     (let* ((h self.head)
-           (pf (nconc (nconc . lists) (cdr h))))
+           (pf [apply nconc (append lists (list (cdr h)))]))
       (usr:rplacd h pf)
       (if (eq self.tail h)
         (set self.tail pf)))
-- 
cgit v1.2.3