summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-06-21 06:37:50 -0700
committerKaz Kylheku <kaz@kylheku.com>2021-06-21 06:37:50 -0700
commitff2df257b64111213fd94028d2f18b75ebdee003 (patch)
tree45cf0a063bfc829c6e619fb8482a215f4884f2ed
parent4605d81ba9ef004e1a0e660ccd5d42717c4c6523 (diff)
downloadtxr-ff2df257b64111213fd94028d2f18b75ebdee003.tar.gz
txr-ff2df257b64111213fd94028d2f18b75ebdee003.tar.bz2
txr-ff2df257b64111213fd94028d2f18b75ebdee003.zip
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.
-rw-r--r--eval.c2
-rw-r--r--lib.c69
-rw-r--r--lib.h2
-rw-r--r--share/txr/stdlib/doc-syms.tl2
-rw-r--r--tests/012/cadr.tl14
-rw-r--r--txr.152
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 )