From d6760da67732419d8043d1fdc43e8081f96ef1f1 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Wed, 22 Jul 2015 20:41:54 -0700
Subject: Adding nthcdr as accessor.

* eval.c (eval_init): Register nthcdr function.

* lib.c (nthcdr): New function.

* lib.h (nthcdr): Declared.

* share/txr/stdlib/place.tl (nthcdr): New defplace.

* txr.1: Documented.
---
 share/txr/stdlib/place.tl | 20 ++++++++++++++++++++
 1 file changed, 20 insertions(+)

(limited to 'share')

diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index e19caa2f..f086ce31 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -355,6 +355,26 @@
                          (prog1 (cdr ,tmp) (,csetter (car ,tmp))))))))
        ,body)))
 
+(defplace (nthcdr index list) body
+  (getter setter
+    (with-gensyms (index-sym sentinel-head-sym parent-cell-sym)
+      (if (place-form-p list)
+        (with-update-expander (lgetter lsetter) list nil
+          ^(rlet ((,index-sym ,index))
+             (let* ((,sentinel-head-sym (cons nil (,lgetter)))
+                    (,parent-cell-sym (nthcdr ,index-sym ,sentinel-head-sym)))
+               (macrolet ((,getter () ^(cdr ,',parent-cell-sym))
+                          (,setter (val)
+                            ^(progn (sys:rplacd ,',parent-cell-sym ,val)
+                                    (,',lsetter (cdr ,',sentinel-head-sym)))))
+                 ,body))))
+        ^(rlet ((,index-sym ,index))
+           (let* ((,parent-cell-sym (nthcdr (pred ,index-sym) ,list)))
+             (macrolet ((,getter () ^(cdr ,',parent-cell-sym))
+                        (,setter (val)
+                          ^(sys:rplacd ,',parent-cell-sym ,val)))
+               ,body)))))))
+
 (defplace (vecref vector index :whole args) body
   (getter setter
     (with-gensyms (vec-sym ind-sym)
-- 
cgit v1.2.3