New accessors nthlast and butlastn.

* eval.c (eval_init): register nthlast and butlastn
intrinsicis.

* lib.c (nthlast, butlastn): New function.

* lib.h (nthlast, butlastn): Declared.

* share/txr/stdlib/place.tl (defplace nthlast,
defplace butlastn): New places.

* txr.1: Documented nthlast and butlastn.

5 files changed, 239 insertions, 0 deletions

diff --git a/eval.c b/eval.c
index 4deab1c9..60fdb205 100644
--- a/eval.c
+++ b/eval.c
@@ -4977,7 +4977,9 @@ void eval_init(void)
   reg_fun(intern(lit("ldiff"), user_package), func_n2(ldiff));
   reg_fun(intern(lit("last"), user_package), func_n1(last));
   reg_fun(intern(lit("butlast"), user_package), func_n1(butlast));
+  reg_fun(intern(lit("nthlast"), user_package), func_n2(nthlast));
   reg_fun(intern(lit("nthcdr"), user_package), func_n2(nthcdr));
+  reg_fun(intern(lit("butlastn"), user_package), func_n2(butlastn));
   reg_fun(intern(lit("flatten"), user_package), func_n1(flatten));
   reg_fun(intern(lit("flatten*"), user_package), func_n1(lazy_flatten));
   reg_fun(intern(lit("flatcar"), user_package), func_n1(flatcar));
diff --git a/lib.c b/lib.c
index 5a65e6c7..0beb76f4 100644
--- a/lib.c
+++ b/lib.c
@@ -599,6 +599,37 @@ val nthcdr(val pos, val list)
   return list;
 }
 
+val nthlast(val pos, val list)
+{
+  val iter = list;
+
+  while (plusp(pos) && consp(list)) {
+    list = cdr(list);
+    pos = pred(pos);
+  }
+
+  if (plusp(pos))
+    return iter;
+
+  if (list == iter) {
+    while (consp(iter))
+      iter = cdr(iter);
+  } else {
+    while (consp(list)) {
+      iter = cdr(iter);
+      list = cdr(list);
+    }
+  }
+
+  return iter;
+}
+
+val butlastn(val n, val list)
+{
+  val tail = nthlast(n, list);
+  return ldiff(list, tail);
+}
+
 loc ltail(loc cons)
 {
   while (cdr(deref(cons)))
diff --git a/lib.h b/lib.h
index 872747af..5092d73d 100644
--- a/lib.h
+++ b/lib.h
@@ -508,7 +508,9 @@ loc tail(val cons);
 loc term(loc head);
 loc lastcons(val list);
 val last(val list);
+val nthlast(val pos, val list);
 val nthcdr(val pos, val list);
+val butlastn(val n, val list);
 loc ltail(loc cons);
 val pop(val *plist);
 val upop(val *plist, val *pundo);
diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index 198dbb19..320cf90e 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -478,6 +478,45 @@
                           ^(sys:rplacd ,',parent-cell-sym ,val)))
                ,body)))))))
 
+(defplace (nthlast index list) body
+  (getter setter
+    (with-gensyms (index-sym list-sym sentinel-head-sym parent-cell-sym)
+      (if (place-form-p list sys:*pl-env*)
+        (with-update-expander (lgetter lsetter) list nil
+          ^(alet ((,index-sym ,index)
+                  (,list-sym (,lgetter)))
+             (let* ((,sentinel-head-sym (cons nil ,list-sym))
+                    (,parent-cell-sym (nthlast (succ ,index-sym)
+                                               ,sentinel-head-sym)))
+               (macrolet ((,getter () ^(cdr ,',parent-cell-sym))
+                          (,setter (val)
+                            ^(prog1 (sys:rplacd ,',parent-cell-sym ,val)
+                                    (,',lsetter (cdr ,',sentinel-head-sym)))))
+                 ,body))))
+        ^(alet ((,index-sym index)
+                (,list-sym ,list))
+           (let ((,parent-cell-sym (nthlast (succ ,index-sym) ,list-sym)))
+             (macrolet ((,getter () ^(cdr ,',parent-cell-sym))
+                        (,setter (val)
+                          ^(sys:rplacd ,',parent-cell-sym ,val)))
+               ,body)))))))
+
+(defplace (butlastn num list) body
+  (getter setter
+    (with-gensyms (num-sym list-sym head-sym tail-sym val-sym)
+      (with-update-expander (lgetter lsetter) list nil
+        ^(alet ((,num-sym ,num)
+                (,list-sym (,lgetter)))
+           (let* ((,tail-sym (nthlast ,num-sym ,list-sym))
+                  (,head-sym (ldiff ,list-sym ,tail-sym)))
+             (macrolet ((,getter () ,head-sym)
+                        (,setter (val)
+                           ^(alet ((,',val-sym ,val))
+                              (progn (,',lsetter (append ,',val-sym
+                                                         ,',tail-sym))
+                                     ,',val-sym))))
+               ,body)))))))
+
 (defplace (vecref vector index :whole args) body
   (getter setter
     (with-gensyms (vec-sym ind-sym)
diff --git a/txr.1 b/txr.1
index b3091b61..bb739b47 100644
--- a/txr.1
+++ b/txr.1
@@ -16614,6 +16614,171 @@ is returned, or an empty suffix if
 .code seq
 is an empty sequence.
 
+.coNP Accessor @ nthlast
+.synb
+.mets (nthlast < index << list )
+.mets (set (nthlast < index << list ) << new-value )
+.syne
+.desc
+The
+.code nthlast
+function retrieves the n-th last cons cell of a list,
+indexed from one.
+The
+.meta index
+parameter must be a an integer. If
+.meta index
+is positive and so large that it specifies a nonexistent cons beyond the
+beginning of the list,
+.code nthlast
+returns
+.metn list .
+Effectively, values of
+.meta index
+larger than the length of the list are clamped to the length.
+If
+.meta index
+is negative, then
+.code nthlast
+yields nil. An
+.meta index
+value of zero retrieves the terminating atom of
+.meta list
+or else the value
+.meta list
+itself, if
+.meta list
+is an atom.
+
+The following equivalences hold:
+
+.cblk
+  (nthlast 1 list) <--> (last list)
+.cble
+
+An
+.code nthlast
+place designates the storage location which holds the n-th cell,
+as indicated by the value of
+.metn index .
+
+A negative
+.meta index
+doesn't denote a place.
+
+A positive
+.meta index
+greater than the length of the list is treated as if it were
+equal to the length of the list.
+
+If
+.meta list
+is itself a syntactic place, then the
+.meta index
+value
+.I n
+is permitted for a list of length
+.IR n .
+This index value denotes the
+.meta list
+place itself.  Storing to this value overwrites
+.metn list .
+If
+.meta list
+isn't a syntactic place, then storing to position
+.I n
+isn't permitted.
+
+If
+.meta list
+is is of length zero, or an atom (in which case its
+length is considered to be zero) then the above
+remarks about position
+.I n
+apply to an
+.meta index
+value of zero: if
+.meta list
+is a syntactic place, then the position denotes
+.meta list
+itself, otherwise the position doesn't exist as a place.
+
+If
+.meta list
+contains one or more elements, then
+.meta index
+value of zero denotes the
+.code cdr
+field of its last cons cell. Storing a value to this
+place overwrites the terminating atom.
+
+.coNP Accessor @ butlastn
+.synb
+.mets (butlastn < num << list )
+.mets (set (butlastn < num << list ) new-value )
+.syne
+.desc
+The
+.code butlastn
+function calculates that initial portion of
+.meta list
+which excludes the last
+.meta num
+elements.
+
+Note: the
+.code butlastn
+function doesn't support non-list sequences as sequences;
+it treats them as the terminating atom of a zero-length improper list.
+The
+.code butlast
+sequence function supports non-list sequences. If
+.code x
+is a list, then the following equivalence holds:
+
+.cblk
+  (butlastn n x)  <-->  (butlast x n)
+.cble
+
+If
+.meta num
+is zero, or negative, then
+.code butlastn
+returns
+.metn list .
+
+If
+.meta num
+is positive, and meets or exceeds the length of
+.metn list ,
+then
+.code butlastn
+returns
+.codn nil .
+
+If a
+.code butlastn
+form is used as a syntactic place, then
+.meta list
+must be a place. Assigning to the form causes
+.meta list
+to be replaced with a new list which is a catenation
+of the new value and the last
+.meta num
+elements of the original list, according to the following equivalence:
+
+.cblk
+  (set (butlastn n x) v)  <--> (progn (set x (append v (nthlast n x)))
+                                      v)
+.cble
+
+except that
+.codn n ,
+.code x
+and
+.code v
+are evaluated only once, in left-to-right order.
+
 .coNP Accessor @ nthcdr
 .synb
 .mets (nthcdr < index << list )