Spat of new features having to do with lazy processing.

* eval.c (prog1_s, gen_s, generate_s, delay_s, promise_s): New symbol
variables.
(eval_prog1, op_prog1, expand_gen, expand_delay): New static functions.
(expand): Handle gen and delay.
(lazy_mapcar_func, lazy_mapcar, lazy_mapcarv_func, lazy_mapcarv,
lazy_mappendv): New static functions.
(rangev_func, rangev, generate_func, generate, repeat_infinite_func,
repeat_times_func, repeatv, force): New static functions.
(eval_init): New operators and functions interned.
lazy-flatten renamed to flatten*.

* lib.c (null_f): New global variable.
(ltail, lazy_appendv): New functions.
(lazy_appendv_func): New static function.
(obj_init): null_f protected and initialized.

* lib.h (null_f, ltail, lazy_appendv): Declared.

* txr.1: Documented.

* txr.vim: Updated.

1 files changed, 223 insertions, 5 deletions

diff --git a/eval.c b/eval.c
index 11998a81..3798dca5 100644
--- a/eval.c
+++ b/eval.c
@@ -51,11 +51,12 @@ val top_vb, top_fb;
 val op_table;
 
 val eval_error_s;
-val progn_s, let_s, let_star_s, lambda_s, call_s;
+val progn_s, prog1_s, let_s, let_star_s, lambda_s, call_s;
 val cond_s, if_s, defvar_s, defun_s;
 val inc_s, dec_s, push_s, pop_s, flip_s, gethash_s, car_s, cdr_s, vecref_s;
 val for_s, for_star_s, dohash_s, uw_protect_s, return_s, return_from_s;
-val list_s, append_s, apply_s;
+val list_s, append_s, apply_s, gen_s, generate_s;
+val delay_s, promise_s;
 
 val make_env(val vbindings, val fbindings, val up_env)
 {
@@ -373,6 +374,21 @@ val eval_progn(val forms, val env, val ctx_form)
   return retval;
 }
 
+static val eval_prog1(val forms, val env, val ctx_form)
+{
+  val retval = nil;
+
+  if (forms) {
+    retval = eval(car(forms), env, ctx_form);
+    forms = cdr(forms);
+  }
+
+  for (; forms; forms = cdr(forms))
+    eval(car(forms), env, ctx_form);
+
+  return retval;
+}
+
 static val op_quote(val form, val env)
 {
   return second(form);
@@ -430,6 +446,11 @@ static val op_progn(val form, val env)
   return eval_progn(rest(form), env, form);
 }
 
+static val op_prog1(val form, val env)
+{
+  return eval_prog1(rest(form), env, form);
+}
+
 static val op_let(val form, val env)
 {
   val let = first(form);
@@ -968,6 +989,20 @@ static val expand_quasi(val quasi_forms)
   }
 }
 
+static val expand_gen(val args)
+{
+  return list(generate_s,
+              list(lambda_s, nil, first(args), nao),
+              list(lambda_s, nil, second(args), nao), nao);
+}
+
+static val expand_delay(val args)
+{
+  return list(cons_s,
+              cons(quote_s, cons(promise_s, nil)),
+              cons(lambda_s, cons(nil, args)), nao);
+}
+
 val expand(val form)
 {
   if (atom(form)) {
@@ -1089,9 +1124,14 @@ val expand(val form)
       if (quasi == quasi_ex)
         return form;
       return rlcp(cons(sym, quasi_ex), form);
+    } else if (sym == gen_s) {
+      return expand(expand_gen(rest(form)));
+    } else if (sym == delay_s) {
+      return expand(expand_delay(rest(form)));
     } else {
-      /* funtion call */
-      /* also handles: progn, call, if, and, or, unwind-protect, return */
+      /* funtion call
+         also handles: progn, prog1, call, if, and, or, 
+         unwind-protect, return  */
       val args = rest(form);
       val args_ex = expand_forms(args);
 
@@ -1153,11 +1193,176 @@ static val mappendv(val fun, val list_of_lists)
   }
 }
 
+static val lazy_mapcar_func(val env, val lcons)
+{
+  cons_bind (fun, list, env);
+
+  rplaca(lcons, funcall1(fun, car(list)));
+  rplacd(env, cdr(list));
+
+  if (cdr(list))
+    rplacd(lcons, make_lazy_cons(lcons_fun(lcons)));
+  else
+    rplacd(lcons, nil);
+  return nil;
+}
+
+static val lazy_mapcar(val fun, val list)
+{
+  if (!list)
+    return nil;
+  return make_lazy_cons(func_f1(cons(fun, list), lazy_mapcar_func));
+}
+
+static val lazy_mapcarv_func(val env, val lcons)
+{
+  cons_bind (fun, lofl, env);
+  val args = mapcar(car_f, lofl);
+  val next = mapcar(cdr_f, lofl);
+
+  rplaca(lcons, apply(fun, args, nil));
+  rplacd(env, next);
+
+  if (all_satisfy(next, identity_f, identity_f))
+    rplacd(lcons, make_lazy_cons(lcons_fun(lcons)));
+  else
+    rplacd(lcons, nil);
+  return nil;
+}
+
+static val lazy_mapcarv(val fun, val list_of_lists)
+{
+  if (!cdr(list_of_lists)) {
+    return lazy_mapcar(fun, car(list_of_lists));
+  } else if (some_satisfy(list_of_lists, null_f, identity_f)) {
+    return nil;
+  } else {
+    val lofl = copy_list(list_of_lists);
+    return make_lazy_cons(func_f1(cons(fun, lofl), lazy_mapcarv_func));
+  }
+}
+
+static val lazy_mappendv(val fun, val list_of_lists)
+{
+  return lazy_appendv(lazy_mapcarv(fun, list_of_lists));
+}
+
 static val symbol_function(val sym)
 {
   return lookup_fun(nil, sym);
 }
 
+static val rangev_func(val env, val lcons)
+{
+  cons_bind (from, to_step, env);
+  cons_bind (to, step, to_step);
+
+  rplaca(lcons, from);
+
+  if (equal(from, to)) {
+    rplacd(lcons, nil);
+    return nil;
+  }
+
+  if (functionp(step))
+    rplaca(env, funcall1(step, from));
+  else
+    rplaca(env, plus(from, step));
+  rplacd(lcons, make_lazy_cons(lcons_fun(lcons)));
+  return nil;
+}
+
+static val rangev(val args)
+{
+  uses_or2;
+  val from = or2(first(args), zero);
+  val to = second(args);
+  val step = or2(third(args), one);
+  val env = cons(from, cons(to, step));
+
+  return make_lazy_cons(func_f1(env, rangev_func));
+}
+
+static val generate_func(val env, val lcons)
+{
+  cons_bind (while_pred, gen_fun, env);
+
+  if (!funcall(while_pred)) {
+    rplacd(lcons, nil);
+  } else {
+    val next_item = funcall(gen_fun);
+    val lcons_next = make_lazy_cons(lcons_fun(lcons));
+    rplacd(lcons, lcons_next);
+    rplaca(lcons_next, next_item);
+  }
+  return nil;
+}
+
+static val generate(val while_pred, val gen_fun)
+{
+  val first_item = funcall(gen_fun);
+  if (!funcall(while_pred)) {
+    return nil;
+  } else {
+    val lc = make_lazy_cons(func_f1(cons(while_pred, gen_fun), generate_func));
+    rplaca(lc, first_item);
+    return lc;
+  }
+}
+
+static val repeat_infinite_func(val env, val lcons)
+{
+  if (!car(env))
+    rplaca(env, cdr(env));
+  rplaca(lcons, pop(car_l(env)));
+  rplacd(lcons, make_lazy_cons(lcons_fun(lcons)));
+  return nil;
+}
+
+static val repeat_times_func(val env, val lcons)
+{
+  cons_bind (stack, list_count, env);
+  cons_bind (list, count, list_count);
+
+  if (!stack) {
+    rplaca(env, list);
+    rplacd(list_count, count = minus(count, one));
+  }
+
+  rplaca(lcons, pop(car_l(env)));
+
+  if (!car(env) && count == one) {
+    rplacd(lcons, nil);
+    return nil;
+  }
+
+  rplacd(lcons, make_lazy_cons(lcons_fun(lcons)));
+  return nil;
+}
+
+static val repeatv(val list, val rest)
+{
+  if (!list)
+    return nil;
+  if (rest) {
+    val count = car(rest);
+    if (count == zero)
+      return nil;
+    return make_lazy_cons(func_f1(cons(list, cons(list, count)), 
+                                  repeat_times_func));
+  }
+  return make_lazy_cons(func_f1(cons(list, list), repeat_infinite_func));
+}
+
+static val force(val promise)
+{
+  if (car(promise) != promise_s)
+    return cdr(promise);
+
+  rplaca(promise, nil);
+  return rplacd(promise, funcall(cdr(promise)));
+}
+
 static void reg_fun(val sym, val fun)
 {
   sethash(top_fb, sym, cons(sym, fun));
@@ -1176,6 +1381,7 @@ void eval_init(void)
   op_table = make_hash(nil, nil, nil);
 
   progn_s = intern(lit("progn"), user_package);
+  prog1_s = intern(lit("prog1"), user_package);
   let_s = intern(lit("let"), user_package);
   let_star_s = intern(lit("let*"), user_package);
   lambda_s = intern(lit("lambda"), user_package);
@@ -1202,12 +1408,17 @@ void eval_init(void)
   list_s = intern(lit("list"), user_package);
   append_s = intern(lit("append"), user_package);
   apply_s = intern(lit("apply"), user_package);
+  gen_s = intern(lit("gen"), user_package);
+  generate_s = intern(lit("generate"), user_package);
+  delay_s = intern(lit("delay"), user_package);
+  promise_s = intern(lit("promise"), system_package);
 
   sethash(op_table, quote_s, cptr((mem_t *) op_quote));
   sethash(op_table, qquote_s, cptr((mem_t *) op_qquote_error));
   sethash(op_table, unquote_s, cptr((mem_t *) op_unquote_error));
   sethash(op_table, splice_s, cptr((mem_t *) op_unquote_error));
   sethash(op_table, progn_s, cptr((mem_t *) op_progn));
+  sethash(op_table, prog1_s, cptr((mem_t *) op_prog1));
   sethash(op_table, let_s, cptr((mem_t *) op_let));
   sethash(op_table, let_star_s, cptr((mem_t *) op_let));
   sethash(op_table, lambda_s, cptr((mem_t *) op_lambda));
@@ -1257,7 +1468,9 @@ void eval_init(void)
   reg_fun(intern(lit("length-list"), user_package), func_n1(length_list));
 
   reg_fun(intern(lit("mapcar"), user_package), func_n1v(mapcarv));
+  reg_fun(intern(lit("mapcar*"), user_package), func_n1v(lazy_mapcarv));
   reg_fun(intern(lit("mappend"), user_package), func_n1v(mappendv));
+  reg_fun(intern(lit("mappend*"), user_package), func_n1v(lazy_mappendv));
   reg_fun(apply_s, func_n2(apply_intrinsic));
   reg_fun(intern(lit("reduce-left"), user_package), func_n4(reduce_left));
   reg_fun(intern(lit("reduce-right"), user_package), func_n4(reduce_right));
@@ -1272,7 +1485,7 @@ void eval_init(void)
   reg_fun(intern(lit("reverse"), user_package), func_n1(reverse));
   reg_fun(intern(lit("ldiff"), user_package), func_n2(ldiff));
   reg_fun(intern(lit("flatten"), user_package), func_n1(flatten));
-  reg_fun(intern(lit("lazy-flatten"), user_package), func_n1(lazy_flatten));
+  reg_fun(intern(lit("flatten*"), user_package), func_n1(lazy_flatten));
   reg_fun(intern(lit("memq"), user_package), func_n2(memq));
   reg_fun(intern(lit("memql"), user_package), func_n2(memql));
   reg_fun(intern(lit("memqual"), user_package), func_n2(memqual));
@@ -1445,6 +1658,11 @@ void eval_init(void)
   reg_fun(intern(lit("random-fixnum"), user_package), func_n1(random_fixnum));
   reg_fun(intern(lit("random"), user_package), func_n2(random));
 
+  reg_fun(intern(lit("range"), user_package), func_n0v(rangev));
+  reg_fun(generate_s, func_n2(generate));
+  reg_fun(intern(lit("repeat"), user_package), func_n1v(repeatv));
+  reg_fun(intern(lit("force"), user_package), func_n1(force));
+
   eval_error_s = intern(lit("eval-error"), user_package);
   uw_register_subtype(eval_error_s, error_s);
 }