From fca47effb1490e6308be3f9600fe782f3cdea862 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Thu, 23 Jan 2014 00:17:33 -0800
Subject: * lib.c (conses, lazy_conses, func_set_env): New functions.
 (lazy_conses_func): New static function.

* lib.h (conses, lazy_conses, func_set_env): Declared.

* eval.c (eval_init): conses, lazy_conses and func_set_env registered
as intrinsics.

* txr.1: Documented.
---
 ChangeLog | 12 ++++++++++++
 eval.c    |  3 +++
 lib.c     | 37 +++++++++++++++++++++++++++++++++++++
 lib.h     |  3 +++
 txr.1     | 48 +++++++++++++++++++++++++++++++++++++++++++++++-
 5 files changed, 102 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index a01223a0..221bc85d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,15 @@
+2014-01-22  Kaz Kylheku  <kaz@kylheku.com>
+
+	* lib.c (conses, lazy_conses, func_set_env): New functions.
+	(lazy_conses_func): New static function.
+
+	* lib.h (conses, lazy_conses, func_set_env): Declared.
+
+	* eval.c (eval_init): conses, lazy_conses and func_set_env registered
+	as intrinsics.
+
+	* txr.1: Documented.
+
 2014-01-22  Kaz Kylheku  <kaz@kylheku.com>
 
 	Changes to the list collection mechanism to improve
diff --git a/eval.c b/eval.c
index 5ea361d8..bd995ff4 100644
--- a/eval.c
+++ b/eval.c
@@ -2351,6 +2351,8 @@ void eval_init(void)
   reg_fun(intern(lit("fourth"), user_package), func_n1(fourth));
   reg_fun(intern(lit("fifth"), user_package), func_n1(fifth));
   reg_fun(intern(lit("sixth"), user_package), func_n1(sixth));
+  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));
   reg_fun(intern(lit("nreverse"), user_package), func_n1(nreverse));
   reg_fun(intern(lit("reverse"), user_package), func_n1(reverse));
@@ -2668,6 +2670,7 @@ void eval_init(void)
   reg_fun(intern(lit("fboundp"), user_package), func_n1(fboundp));
   reg_fun(intern(lit("func-get-form"), user_package), func_n1(func_get_form));
   reg_fun(intern(lit("func-get-env"), user_package), func_n1(func_get_env));
+  reg_fun(intern(lit("func-set-env"), user_package), func_n2(func_set_env));
   reg_fun(intern(lit("functionp"), user_package), func_n1(functionp));
   reg_fun(intern(lit("interp-fun-p"), user_package), func_n1(interp_fun_p));
 
diff --git a/lib.c b/lib.c
index 7da379b6..492e6dcf 100644
--- a/lib.c
+++ b/lib.c
@@ -337,6 +337,36 @@ val sixth(val cons)
   return car(cdr(cdr(cdr(cdr(cdr(cons))))));
 }
 
+val conses(val list)
+{
+  list_collect_decl (out, ptail);
+
+  for (; consp(list); list = cdr(list))
+    ptail = list_collect(ptail, list);
+
+  return out;
+}
+
+static val lazy_conses_func(val env, val lcons)
+{
+  val fun = lcons_fun(lcons);
+  rplaca(lcons, env);
+  func_set_env(fun, env = cdr(env));
+
+  if (env)
+    rplacd(lcons, make_lazy_cons(fun));
+  else
+    rplacd(lcons, nil);
+  return nil;
+}
+
+val lazy_conses(val list)
+{
+  if (!list)
+    return nil;
+  return make_lazy_cons(func_f1(list, lazy_conses_func));
+}
+
 val listref(val list, val ind)
 {
   if (lt(ind, zero))
@@ -3172,6 +3202,13 @@ val func_get_env(val fun)
   return fun->f.env;
 }
 
+val func_set_env(val fun, val env)
+{
+  type_check(fun, FUN);
+  set(fun->f.env, env);
+  return env;
+}
+
 val functionp(val obj)
 {
   return type(obj) == FUN ? t : nil;
diff --git a/lib.h b/lib.h
index 467866ec..41465747 100644
--- a/lib.h
+++ b/lib.h
@@ -366,6 +366,8 @@ val third(val cons);
 val fourth(val cons);
 val fifth(val cons);
 val sixth(val cons);
+val conses(val list);
+val lazy_conses(val list);
 val listref(val list, val ind);
 val *listref_l(val list, val ind);
 val *tail(val cons);
@@ -597,6 +599,7 @@ val func_n4o(val (*fun)(val, val, val, val), int reqargs);
 val func_interp(val env, val form);
 val func_get_form(val fun);
 val func_get_env(val fun);
+val func_set_env(val fun, val env);
 val functionp(val);
 val interp_fun_p(val);
 val funcall(val fun);
diff --git a/txr.1 b/txr.1
index 8c7683e9..ed33cfae 100644
--- a/txr.1
+++ b/txr.1
@@ -7027,12 +7027,58 @@ Examples:
   (mappend (lambda (item) (if (evenp x) (list x))) '(1 2 3 4 5))
   -> (2 4)
 
+.SS Functions conses and conses*
+
+.TP
+Syntax:
+
+  (conses <list>)
+  (conses* <list>)
+
+.TP
+Description:
+
+These functions return a list whose elements are the conses which make
+up <list>. The conses* function does this in a lazy way, avoiding the
+computation of the entire list: it returns a lazy list of the conses of <list>.
+The conses function computes the entire list before returning.
+
+The input <list> may be proper or improper.
+
+The first cons of a list is that list itself. The second cons is the rest
+of the list, or (cdr <list>). The third cons is (cdr (cdr <list>)) and so on.
+
+.TP
+Example:
+
+  (conses '(1 2 3)) -> ((1 2 3) (2 3) (3))
+
+.TP
+Dialect Note:
+
+These functions are useful for simulating the maplist function found in
+other dialects like Common Lisp. 
+
+TXR Lisp's (conses x) can be expressed in Common Lisp as
+(maplist #'identity x).
+
+Conversely, the Common Lisp operation (maplist function list) can be computed
+in TXR Lisp as (mapcar function (conses list)).
+
+More generally, the Common Lisp operation
+
+  (maplist function list0 list1 ... listn)
+  
+can be expressed as:
+
+  (mapcar function (conses list0) (conses list1) ... (conses listn))
+
 .SS Function apply
 
 .TP
 Syntax:
 
-(apply <function> <arglist>)
+  (apply <function> <arglist>)
 
 .TP
 Description:
-- 
cgit v1.2.3