From 229de13e3ddaaf1ead3f0c09be87abcd97be61bf Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Mon, 9 Sep 2019 06:52:02 -0700
Subject: Bugfix: incorrect appending to improper lists.

The list building framework underlying the list_collect_decl
macro has a flaw: if the current list ends in an non-nil
terminating atom, and the tail pointer isn't directly aiming
at that atom, then a subsequent operation to add an item or
append a suffix will just overwrite the atom.

The correct behavior is to execute the same logic as if the
tail pointer pointed at that atom on entry into the function:
switch on the type of the atom, and append to it, if possible,
or else throw an error.

Thus, for instance, (append '(1 2 3 . 42) '(4)) wrongly
returns (1 2 3 4), instead of producing an error. The 42
atom has disappeared.

The example (append '(1 2 . "ab") "c") -> (1 2 . "abc")
given in the man page doesn't work; it yields (1 2 . "c").

* lib.c (list_collect, list_collect_nconc,
list_collect_append, list_collect_revappend,
list_collect_nreconc): In the cases when the current tail
object is a CONS and LCONS, and we move the tail, we must
branch backwards and process the tail atom as if the tail had
been that way on entry into the function. Doing this with a
tail call would be nice, but in some of the functions, we hold
a local resource already, so we simulate a local tail call
by updating the tailobj variable and doing a backwards goto.
---
 lib.c | 25 ++++++++++++++++---------
 1 file changed, 16 insertions(+), 9 deletions(-)

(limited to 'lib.c')

diff --git a/lib.c b/lib.c
index 225ea92d..c76c4864 100644
--- a/lib.c
+++ b/lib.c
@@ -1046,6 +1046,7 @@ loc list_collect(loc ptail, val obj)
   val items = cons(obj, nil);
   val tailobj = deref(ptail);
 
+again:
   switch (type(tailobj)) {
   case NIL:
     set(ptail, items);
@@ -1053,8 +1054,8 @@ loc list_collect(loc ptail, val obj)
   case CONS:
   case LCONS:
     ptail = tail(tailobj);
-    set(ptail, items);
-    return ptail;
+    tailobj = deref(ptail);
+    goto again;
   case VEC:
     replace_vec(tailobj, items, t, t);
     return ptail;
@@ -1084,6 +1085,7 @@ loc list_collect_nconc(loc ptail, val obj)
 {
   val tailobj = deref(ptail);
 
+again:
   switch (type(tailobj)) {
   case NIL:
     set(ptail, nullify(obj));
@@ -1091,8 +1093,8 @@ loc list_collect_nconc(loc ptail, val obj)
   case CONS:
   case LCONS:
     ptail = tail(tailobj);
-    set(ptail, nullify(obj));
-    return ptail;
+    tailobj = deref(ptail);
+    goto again;
   case VEC:
     replace_vec(tailobj, obj, t, t);
     return ptail;
@@ -1110,7 +1112,7 @@ loc list_collect_nconc(loc ptail, val obj)
     set(ptail, tolist(obj));
     return ptail;
   default:
-    uw_throwf(error_s, lit("cannot nconc ~s to ~s"), obj, tailobj, nao);
+    uw_throwf(error_s, lit("cannot nconc to ~s"), tailobj, nao);
   }
 }
 
@@ -1119,6 +1121,7 @@ loc list_collect_append(loc ptail, val obj)
   val tailobj = deref(ptail);
   obj = nullify(obj);
 
+again:
   switch (type(tailobj)) {
   case NIL:
     set(ptail, obj);
@@ -1127,8 +1130,8 @@ loc list_collect_append(loc ptail, val obj)
   case LCONS:
     set(ptail, copy_list(tailobj));
     ptail = tail(deref(ptail));
-    set(ptail, obj);
-    return ptail;
+    tailobj = deref(ptail);
+    goto again;
   case VEC:
     set(ptail, copy_vec(tailobj));
     replace_vec(deref(ptail), obj, t, t);
@@ -1158,11 +1161,13 @@ loc list_collect_nreconc(loc ptail, val obj)
   val rev = nreverse(nullify(obj));
   val tailobj = deref(ptail);
 
+again:
   switch (type(tailobj)) {
   case CONS:
   case LCONS:
     ptail = tail(tailobj);
-    /* fallthrough */
+    tailobj = deref(ptail);
+    goto again;
   case NIL:
     set(ptail, rev);
     switch (type(obj)) {
@@ -1213,12 +1218,14 @@ loc list_collect_revappend(loc ptail, val obj)
   obj = nullify(obj);
   val tailobj = deref(ptail);
 
+again:
   switch (type(tailobj)) {
   case CONS:
   case LCONS:
     set(ptail, copy_list(tailobj));
     ptail = tail(deref(ptail));
-    /* fallthrough */
+    tailobj = deref(ptail);
+    goto again;
   case NIL:
     switch (type(obj)) {
     case CONS:
-- 
cgit v1.2.3