Dubious new functions cxr/cyr.

* lib.c (cxr, cyr): New functions.

* lib.h (cxr, cyr): Declared.

* eval.c (eval_init): Intrinsics cxr and cyr registered.

* tests/012/cadr.tl: New file.

* txr.1: Documented.

* share/txr/stdlib/doc-syms.tl: Updated.

6 files changed, 141 insertions, 0 deletions

diff --git a/eval.c b/eval.c
index bdbec0be..23579af3 100644
--- a/eval.c
+++ b/eval.c
@@ -6740,6 +6740,8 @@ void eval_init(void)
   reg_fun(intern(lit("eighth"), user_package), func_n1(eighth));
   reg_fun(intern(lit("ninth"), user_package), func_n1(ninth));
   reg_fun(intern(lit("tenth"), user_package), func_n1(tenth));
+  reg_fun(intern(lit("cxr"), user_package), func_n2(cxr));
+  reg_fun(intern(lit("cyr"), user_package), func_n2(cyr));
   reg_fun(intern(lit("conses"), user_package), func_n1(conses));
   reg_fun(intern(lit("conses*"), user_package), func_n1(lazy_conses));
   reg_fun(intern(lit("copy-list"), user_package), func_n1(copy_list));
diff --git a/lib.c b/lib.c
index e1e53b37..8df9757a 100644
--- a/lib.c
+++ b/lib.c
@@ -1468,6 +1468,75 @@ val tenth(val obj)
   return ref(obj, num_fast(9));
 }
 
+val cxr(val addr, val obj)
+{
+  val self = lit("cxr");
+
+  switch (type(addr)) {
+  case NUM:
+    {
+      cnum a = c_num(addr, self);
+      if (a > 0) {
+        for (; a != 1; a >>= 1)
+          obj = if3((a & 1) != 0, car(obj), cdr(obj));
+        return obj;
+      }
+    }
+    break;
+  case BGNUM:
+    {
+      mp_int *a = mp(addr);
+      if (!mp_isneg(a)) {
+        mp_size i, n = mp_count_bits(a);
+        for (i = 0; i < n - 1; i++)
+          obj = if3(mp_bit(a, i) == MP_YES, car(obj), cdr(obj));
+        return obj;
+      }
+    }
+    break;
+  default:
+    break;
+  }
+
+  uw_throwf(error_s, lit("~a: ~s is an invalid address"), self, addr, nao);
+}
+
+val cyr(val addr, val obj)
+{
+  val self = lit("cyr");
+
+  switch (type(addr)) {
+  case NUM:
+    {
+      cnum a = c_num(addr, self);
+      if (a > 0) {
+        int m, h = highest_bit(a);
+        if (h > 1) {
+          for (m = 1 << (h - 2); m != 0; m >>= 1)
+            obj = if3((a & m) != 0, car(obj), cdr(obj));
+        }
+        return obj;
+      }
+    }
+    break;
+  case BGNUM:
+    {
+      mp_int *a = mp(addr);
+      if (!mp_isneg(a)) {
+        mp_size i, n = mp_count_bits(a);
+        for (i = n - 2; i != (mp_size) -1; i--)
+          obj = if3(mp_bit(a, i) == MP_YES, car(obj), cdr(obj));
+        return obj;
+      }
+    }
+    break;
+  default:
+    break;
+  }
+
+  uw_throwf(error_s, lit("~a: ~s is an invalid address"), self, addr, nao);
+}
+
 val conses(val list)
 {
   list_collect_decl (out, ptail);
diff --git a/lib.h b/lib.h
index a91a2f9b..2a8ed526 100644
--- a/lib.h
+++ b/lib.h
@@ -603,6 +603,8 @@ val seventh(val cons);
 val eighth(val cons);
 val ninth(val cons);
 val tenth(val cons);
+val cxr(val addr, val obj);
+val cyr(val addr, val obj);
 val conses(val list);
 val lazy_conses(val list);
 val listref(val list, val ind);
diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl
index 4a860470..36e1e197 100644
--- a/share/txr/stdlib/doc-syms.tl
+++ b/share/txr/stdlib/doc-syms.tl
@@ -443,6 +443,8 @@
       ("csize" "N-01B1B5DF")
       ("cstopb" "N-01B1B5DF")
       ("cum-norm-dist" "N-03AB449B")
+      ("cxr" "N-01DA4F04")
+      ("cyr" "N-01DA4F04")
       ("daemon" "N-017C3515")
       ("data" "N-03B6EA7D")
       ("dec" "N-03A0AABD")
diff --git a/tests/012/cadr.tl b/tests/012/cadr.tl
new file mode 100644
index 00000000..509590f7
--- /dev/null
+++ b/tests/012/cadr.tl
@@ -0,0 +1,14 @@
+(load "../common")
+
+(mtest
+  (cxr 1 42) 42
+  (cxr #b11 '(a . b)) a
+  (cxr #b10 '(a . b)) b
+  (cxr #b11000 '(1 2 3 4 5)) 4
+  (cyr #b100001 '(1 2 3 4 5)) 5
+  (cyr #b1111 '(((a)))) a
+  (cyr #b111 '(a)) :error)
+
+(let ((r (range* 0 100)))
+  (vtest (mapcar (op cyr (succ (expt 2 (succ @1))) r) 0..100) r)
+  (vtest (mapcar (op cxr (* 3 (expt 2 @1)) r) 0..100) r))
diff --git a/txr.1 b/txr.1
index 68a79448..ce2ad6c4 100644
--- a/txr.1
+++ b/txr.1
@@ -21598,6 +21598,58 @@ places. For example,
 means the same as
 .codn "(del (car (cddr x)))" .
 
+.coNP Functions @ cyr and @ cxr
+.synb
+.mets (cyr < address << object )
+.mets (cxr < address << object )
+.syne
+.desc
+The
+.code cyr
+and
+.code cxr
+functions provide
+.cod3 car / cdr
+navigation of tree structure driven by numeric address given by the
+.meta address
+argument.
+
+The
+.meta address
+argument can express any combination of the application of
+.code car
+and
+.code cdr
+functions, including none at all.
+
+The difference between
+.code cyr
+and
+.code cxr
+is the bit order of the encoding. Under
+.codn cyr ,
+the most significant bit of the encoding given in
+.meta address
+indicates the initial
+.cod3 car / cdr
+navigation, and the least significant bit gives the final one.
+Under
+.codn cxr ,
+it is opposite.
+
+Both functions require
+.meta address
+to be a positive integer. Any other argument raises an error.
+
+Under both functions, the
+.meta address
+value
+.code 1
+encodes the
+.code identity
+operation: no
+.cod3 car / cdr
+
 .coNP Functions @ flatten and @ flatten*
 .synb
 .mets (flatten << list )